summaryrefslogtreecommitdiff
path: root/Master/tlpkg
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg')
-rw-r--r--Master/tlpkg/tlperl/lib/.packlist2115
-rw-r--r--Master/tlpkg/tlperl/lib/AnyDBM_File.pm93
-rw-r--r--Master/tlpkg/tlperl/lib/AutoLoader.pm429
-rw-r--r--Master/tlpkg/tlperl/lib/AutoSplit.pm592
-rw-r--r--Master/tlpkg/tlperl/lib/B.pm1189
-rw-r--r--Master/tlpkg/tlperl/lib/Benchmark.pm1044
-rw-r--r--Master/tlpkg/tlperl/lib/CGI.pm8096
-rw-r--r--Master/tlpkg/tlperl/lib/CORE.pod62
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN.pm3774
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS.pm271
-rw-r--r--Master/tlpkg/tlperl/lib/Carp.pm538
-rw-r--r--Master/tlpkg/tlperl/lib/Config.pm103
-rw-r--r--Master/tlpkg/tlperl/lib/Config.pmold99
-rw-r--r--Master/tlpkg/tlperl/lib/Config.pod8880
-rw-r--r--Master/tlpkg/tlperl/lib/Config_git.pl12
-rw-r--r--Master/tlpkg/tlperl/lib/Config_heavy.pl1319
-rw-r--r--Master/tlpkg/tlperl/lib/Config_heavy.plold1315
-rw-r--r--Master/tlpkg/tlperl/lib/Cwd.pm824
-rw-r--r--Master/tlpkg/tlperl/lib/DB.pm809
-rw-r--r--Master/tlpkg/tlperl/lib/DBM_Filter.pm605
-rw-r--r--Master/tlpkg/tlperl/lib/Digest.pm316
-rw-r--r--Master/tlpkg/tlperl/lib/DirHandle.pm92
-rw-r--r--Master/tlpkg/tlperl/lib/Dumpvalue.pm648
-rw-r--r--Master/tlpkg/tlperl/lib/DynaLoader.pm771
-rw-r--r--Master/tlpkg/tlperl/lib/Encode.pm963
-rw-r--r--Master/tlpkg/tlperl/lib/English.pm230
-rw-r--r--Master/tlpkg/tlperl/lib/Env.pm254
-rw-r--r--Master/tlpkg/tlperl/lib/Errno.pm2768
-rw-r--r--Master/tlpkg/tlperl/lib/Exporter.pm584
-rw-r--r--Master/tlpkg/tlperl/lib/Fatal.pm1374
-rw-r--r--Master/tlpkg/tlperl/lib/Fcntl.pm244
-rw-r--r--Master/tlpkg/tlperl/lib/FileCache.pm188
-rw-r--r--Master/tlpkg/tlperl/lib/FileHandle.pm262
-rw-r--r--Master/tlpkg/tlperl/lib/FindBin.pm209
-rw-r--r--Master/tlpkg/tlperl/lib/IO.pm68
-rw-r--r--Master/tlpkg/tlperl/lib/Memoize.pm1047
-rw-r--r--Master/tlpkg/tlperl/lib/NEXT.pm563
-rw-r--r--Master/tlpkg/tlperl/lib/O.pm143
-rw-r--r--Master/tlpkg/tlperl/lib/Opcode.pm593
-rw-r--r--Master/tlpkg/tlperl/lib/POSIX.pm1042
-rw-r--r--Master/tlpkg/tlperl/lib/POSIX.pod2218
-rw-r--r--Master/tlpkg/tlperl/lib/PerlIO.pm344
-rw-r--r--Master/tlpkg/tlperl/lib/SDBM_File.pm116
-rw-r--r--Master/tlpkg/tlperl/lib/Safe.pm794
-rw-r--r--Master/tlpkg/tlperl/lib/SelectSaver.pm54
-rw-r--r--Master/tlpkg/tlperl/lib/SelfLoader.pm435
-rw-r--r--Master/tlpkg/tlperl/lib/Shell.pm270
-rw-r--r--Master/tlpkg/tlperl/lib/Socket.pm436
-rw-r--r--Master/tlpkg/tlperl/lib/Storable.pm1188
-rw-r--r--Master/tlpkg/tlperl/lib/Switch.pm875
-rw-r--r--Master/tlpkg/tlperl/lib/Symbol.pm170
-rw-r--r--Master/tlpkg/tlperl/lib/Test.pm954
-rw-r--r--Master/tlpkg/tlperl/lib/Thread.pm273
-rw-r--r--Master/tlpkg/tlperl/lib/Tk.pm856
-rw-r--r--Master/tlpkg/tlperl/lib/Tk.pod862
-rw-r--r--Master/tlpkg/tlperl/lib/UNIVERSAL.pm214
-rw-r--r--Master/tlpkg/tlperl/lib/Win32.pm793
-rw-r--r--Master/tlpkg/tlperl/lib/Win32CORE.pm38
-rw-r--r--Master/tlpkg/tlperl/lib/XSLoader.pm358
-rw-r--r--Master/tlpkg/tlperl/lib/abbrev.pl45
-rw-r--r--Master/tlpkg/tlperl/lib/assert.pl61
-rw-r--r--Master/tlpkg/tlperl/lib/attributes.pm490
-rw-r--r--Master/tlpkg/tlperl/lib/autodie.pm424
-rw-r--r--Master/tlpkg/tlperl/lib/autouse.pm171
-rw-r--r--Master/tlpkg/tlperl/lib/base.pm265
-rw-r--r--Master/tlpkg/tlperl/lib/bigfloat.pl256
-rw-r--r--Master/tlpkg/tlperl/lib/bigint.pl322
-rw-r--r--Master/tlpkg/tlperl/lib/bigint.pm675
-rw-r--r--Master/tlpkg/tlperl/lib/bignum.pm681
-rw-r--r--Master/tlpkg/tlperl/lib/bigrat.pl157
-rw-r--r--Master/tlpkg/tlperl/lib/bigrat.pm566
-rw-r--r--Master/tlpkg/tlperl/lib/blib.pm97
-rw-r--r--Master/tlpkg/tlperl/lib/bytes.pm100
-rw-r--r--Master/tlpkg/tlperl/lib/bytes_heavy.pl40
-rw-r--r--Master/tlpkg/tlperl/lib/cacheout.pl57
-rw-r--r--Master/tlpkg/tlperl/lib/charnames.pm577
-rw-r--r--Master/tlpkg/tlperl/lib/complete.pl122
-rw-r--r--Master/tlpkg/tlperl/lib/constant.pm391
-rw-r--r--Master/tlpkg/tlperl/lib/ctime.pl62
-rw-r--r--Master/tlpkg/tlperl/lib/deprecate.pm105
-rw-r--r--Master/tlpkg/tlperl/lib/diagnostics.pm648
-rw-r--r--Master/tlpkg/tlperl/lib/dotsh.pl76
-rw-r--r--Master/tlpkg/tlperl/lib/dumpvar.pl552
-rw-r--r--Master/tlpkg/tlperl/lib/encoding.pm669
-rw-r--r--Master/tlpkg/tlperl/lib/exceptions.pl62
-rw-r--r--Master/tlpkg/tlperl/lib/fastcwd.pl45
-rw-r--r--Master/tlpkg/tlperl/lib/feature.pm236
-rw-r--r--Master/tlpkg/tlperl/lib/fields.pm327
-rw-r--r--Master/tlpkg/tlperl/lib/filetest.pm117
-rw-r--r--Master/tlpkg/tlperl/lib/find.pl52
-rw-r--r--Master/tlpkg/tlperl/lib/finddepth.pl51
-rw-r--r--Master/tlpkg/tlperl/lib/flush.pl34
-rw-r--r--Master/tlpkg/tlperl/lib/getcwd.pl72
-rw-r--r--Master/tlpkg/tlperl/lib/getopt.pl51
-rw-r--r--Master/tlpkg/tlperl/lib/getopts.pl66
-rw-r--r--Master/tlpkg/tlperl/lib/hostname.pl33
-rw-r--r--Master/tlpkg/tlperl/lib/if.pm56
-rw-r--r--Master/tlpkg/tlperl/lib/importenv.pl19
-rw-r--r--Master/tlpkg/tlperl/lib/integer.pm93
-rw-r--r--Master/tlpkg/tlperl/lib/less.pm158
-rw-r--r--Master/tlpkg/tlperl/lib/lib.pm242
-rw-r--r--Master/tlpkg/tlperl/lib/locale.pm40
-rw-r--r--Master/tlpkg/tlperl/lib/look.pl52
-rw-r--r--Master/tlpkg/tlperl/lib/mro.pm379
-rw-r--r--Master/tlpkg/tlperl/lib/newgetopt.pl77
-rw-r--r--Master/tlpkg/tlperl/lib/open.pm258
-rw-r--r--Master/tlpkg/tlperl/lib/open2.pl15
-rw-r--r--Master/tlpkg/tlperl/lib/open3.pl15
-rw-r--r--Master/tlpkg/tlperl/lib/ops.pm47
-rw-r--r--Master/tlpkg/tlperl/lib/overload.pm1534
-rw-r--r--Master/tlpkg/tlperl/lib/overloading.pm101
-rw-r--r--Master/tlpkg/tlperl/lib/parent.pm136
-rw-r--r--Master/tlpkg/tlperl/lib/perl5db.pl9559
-rw-r--r--Master/tlpkg/tlperl/lib/perllocal.pod110
-rw-r--r--Master/tlpkg/tlperl/lib/pwd.pl69
-rw-r--r--Master/tlpkg/tlperl/lib/re.pm485
-rw-r--r--Master/tlpkg/tlperl/lib/shellwords.pl17
-rw-r--r--Master/tlpkg/tlperl/lib/sigtrap.pm289
-rw-r--r--Master/tlpkg/tlperl/lib/sort.pm196
-rw-r--r--Master/tlpkg/tlperl/lib/stat.pl33
-rw-r--r--Master/tlpkg/tlperl/lib/strict.pm147
-rw-r--r--Master/tlpkg/tlperl/lib/subs.pm40
-rw-r--r--Master/tlpkg/tlperl/lib/syslog.pl199
-rw-r--r--Master/tlpkg/tlperl/lib/tainted.pl12
-rw-r--r--Master/tlpkg/tlperl/lib/termcap.pl181
-rw-r--r--Master/tlpkg/tlperl/lib/threads.pm1066
-rw-r--r--Master/tlpkg/tlperl/lib/timelocal.pl21
-rw-r--r--Master/tlpkg/tlperl/lib/utf8.pm214
-rw-r--r--Master/tlpkg/tlperl/lib/utf8_heavy.pl466
-rw-r--r--Master/tlpkg/tlperl/lib/validate.pl102
-rw-r--r--Master/tlpkg/tlperl/lib/vars.pm82
-rw-r--r--Master/tlpkg/tlperl/lib/version.pm171
-rw-r--r--Master/tlpkg/tlperl/lib/version.pod321
-rw-r--r--Master/tlpkg/tlperl/lib/vmsish.pm154
-rw-r--r--Master/tlpkg/tlperl/lib/warnings.pm544
135 files changed, 82231 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/.packlist b/Master/tlpkg/tlperl/lib/.packlist
new file mode 100644
index 00000000000..d3638479fed
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/.packlist
@@ -0,0 +1,2115 @@
+c:\perl\bin/a2p.exe type=file
+c:\perl\bin/c2ph.bat type=file
+c:\perl\bin/config_data.bat type=file
+c:\perl\bin/corelist.bat type=file
+c:\perl\bin/cpan.bat type=file
+c:\perl\bin/cpan2dist.bat type=file
+c:\perl\bin/cpanp-run-perl.bat type=file
+c:\perl\bin/cpanp.bat type=file
+c:\perl\bin/dprofpp.bat type=file
+c:\perl\bin/enc2xs.bat type=file
+c:\perl\bin/find2perl.bat type=file
+c:\perl\bin/h2ph.bat type=file
+c:\perl\bin/h2xs.bat type=file
+c:\perl\bin/instmodsh.bat type=file
+c:\perl\bin/libnetcfg.bat type=file
+c:\perl\bin/perl.exe from=c:\perl\bin/perl5.12.3.exe type=link
+c:\perl\bin/perl5.12.3.exe type=file
+c:\perl\bin/perl512.dll type=file
+c:\perl\bin/perlbug.bat type=file
+c:\perl\bin/perldoc.bat type=file
+c:\perl\bin/perlivp.bat type=file
+c:\perl\bin/perlthanks.bat from=c:\perl\bin/perlbug.bat type=link
+c:\perl\bin/piconv.bat type=file
+c:\perl\bin/pl2pm.bat type=file
+c:\perl\bin/pod2html.bat type=file
+c:\perl\bin/pod2latex.bat type=file
+c:\perl\bin/pod2man.bat type=file
+c:\perl\bin/pod2text.bat type=file
+c:\perl\bin/pod2usage.bat type=file
+c:\perl\bin/podchecker.bat type=file
+c:\perl\bin/podselect.bat type=file
+c:\perl\bin/prove.bat type=file
+c:\perl\bin/psed.bat from=c:\perl\bin/s2p.bat type=link
+c:\perl\bin/pstruct.bat from=c:\perl\bin/c2ph.bat type=link
+c:\perl\bin/ptar.bat type=file
+c:\perl\bin/ptardiff.bat type=file
+c:\perl\bin/s2p.bat type=file
+c:\perl\bin/shasum.bat type=file
+c:\perl\bin/splain.bat type=file
+c:\perl\bin/xsubpp.bat type=file
+c:\perl\lib/AnyDBM_File.pm type=file
+c:\perl\lib/App/Cpan.pm type=file
+c:\perl\lib/App/Prove.pm type=file
+c:\perl\lib/App/Prove/State.pm type=file
+c:\perl\lib/App/Prove/State/Result.pm type=file
+c:\perl\lib/App/Prove/State/Result/Test.pm type=file
+c:\perl\lib/Archive/Extract.pm type=file
+c:\perl\lib/Archive/Tar.pm type=file
+c:\perl\lib/Archive/Tar/Constant.pm type=file
+c:\perl\lib/Archive/Tar/File.pm type=file
+c:\perl\lib/Attribute/Handlers.pm type=file
+c:\perl\lib/AutoLoader.pm type=file
+c:\perl\lib/AutoSplit.pm type=file
+c:\perl\lib/B.pm type=file
+c:\perl\lib/B/Concise.pm type=file
+c:\perl\lib/B/Debug.pm type=file
+c:\perl\lib/B/Deparse.pm type=file
+c:\perl\lib/B/Lint.pm type=file
+c:\perl\lib/B/Lint/Debug.pm type=file
+c:\perl\lib/B/Showlex.pm type=file
+c:\perl\lib/B/Terse.pm type=file
+c:\perl\lib/B/Xref.pm type=file
+c:\perl\lib/Benchmark.pm type=file
+c:\perl\lib/CGI.pm type=file
+c:\perl\lib/CGI/Apache.pm type=file
+c:\perl\lib/CGI/Carp.pm type=file
+c:\perl\lib/CGI/Cookie.pm type=file
+c:\perl\lib/CGI/Fast.pm type=file
+c:\perl\lib/CGI/Pretty.pm type=file
+c:\perl\lib/CGI/Push.pm type=file
+c:\perl\lib/CGI/Switch.pm type=file
+c:\perl\lib/CGI/Util.pm type=file
+c:\perl\lib/CORE.pod type=file
+c:\perl\lib/CORE/EXTERN.h type=file
+c:\perl\lib/CORE/INTERN.h type=file
+c:\perl\lib/CORE/XSUB.h type=file
+c:\perl\lib/CORE/arpa/inet.h type=file
+c:\perl\lib/CORE/av.h type=file
+c:\perl\lib/CORE/bitcount.h type=file
+c:\perl\lib/CORE/cc_runtime.h type=file
+c:\perl\lib/CORE/config.h type=file
+c:\perl\lib/CORE/cop.h type=file
+c:\perl\lib/CORE/cv.h type=file
+c:\perl\lib/CORE/dirent.h type=file
+c:\perl\lib/CORE/dosish.h type=file
+c:\perl\lib/CORE/embed.h type=file
+c:\perl\lib/CORE/embedvar.h type=file
+c:\perl\lib/CORE/fakesdio.h type=file
+c:\perl\lib/CORE/fakethr.h type=file
+c:\perl\lib/CORE/form.h type=file
+c:\perl\lib/CORE/git_version.h type=file
+c:\perl\lib/CORE/gv.h type=file
+c:\perl\lib/CORE/handy.h type=file
+c:\perl\lib/CORE/hv.h type=file
+c:\perl\lib/CORE/intrpvar.h type=file
+c:\perl\lib/CORE/iperlsys.h type=file
+c:\perl\lib/CORE/keywords.h type=file
+c:\perl\lib/CORE/libperl512.a type=file
+c:\perl\lib/CORE/malloc_ctl.h type=file
+c:\perl\lib/CORE/mg.h type=file
+c:\perl\lib/CORE/mydtrace.h type=file
+c:\perl\lib/CORE/netdb.h type=file
+c:\perl\lib/CORE/nostdio.h type=file
+c:\perl\lib/CORE/op.h type=file
+c:\perl\lib/CORE/opcode.h type=file
+c:\perl\lib/CORE/opnames.h type=file
+c:\perl\lib/CORE/overload.h type=file
+c:\perl\lib/CORE/pad.h type=file
+c:\perl\lib/CORE/parser.h type=file
+c:\perl\lib/CORE/patchlevel.h type=file
+c:\perl\lib/CORE/perl.h type=file
+c:\perl\lib/CORE/perlapi.h type=file
+c:\perl\lib/CORE/perlhost.h type=file
+c:\perl\lib/CORE/perlio.h type=file
+c:\perl\lib/CORE/perliol.h type=file
+c:\perl\lib/CORE/perlsdio.h type=file
+c:\perl\lib/CORE/perlsfio.h type=file
+c:\perl\lib/CORE/perlvars.h type=file
+c:\perl\lib/CORE/perly.h type=file
+c:\perl\lib/CORE/pp.h type=file
+c:\perl\lib/CORE/pp_proto.h type=file
+c:\perl\lib/CORE/proto.h type=file
+c:\perl\lib/CORE/reentr.h type=file
+c:\perl\lib/CORE/regcharclass.h type=file
+c:\perl\lib/CORE/regcomp.h type=file
+c:\perl\lib/CORE/regexp.h type=file
+c:\perl\lib/CORE/regnodes.h type=file
+c:\perl\lib/CORE/scope.h type=file
+c:\perl\lib/CORE/sv.h type=file
+c:\perl\lib/CORE/sys/socket.h type=file
+c:\perl\lib/CORE/thread.h type=file
+c:\perl\lib/CORE/time64.h type=file
+c:\perl\lib/CORE/time64_config.h type=file
+c:\perl\lib/CORE/uconfig.h type=file
+c:\perl\lib/CORE/unixish.h type=file
+c:\perl\lib/CORE/utf8.h type=file
+c:\perl\lib/CORE/utfebcdic.h type=file
+c:\perl\lib/CORE/util.h type=file
+c:\perl\lib/CORE/uudmap.h type=file
+c:\perl\lib/CORE/vdir.h type=file
+c:\perl\lib/CORE/vmem.h type=file
+c:\perl\lib/CORE/warnings.h type=file
+c:\perl\lib/CORE/win32.h type=file
+c:\perl\lib/CORE/win32iop-o.h type=file
+c:\perl\lib/CORE/win32iop.h type=file
+c:\perl\lib/CORE/win32thread.h type=file
+c:\perl\lib/CORE/wince.h type=file
+c:\perl\lib/CPAN.pm type=file
+c:\perl\lib/CPAN/API/HOWTO.pod type=file
+c:\perl\lib/CPAN/Author.pm type=file
+c:\perl\lib/CPAN/Bundle.pm type=file
+c:\perl\lib/CPAN/CacheMgr.pm type=file
+c:\perl\lib/CPAN/Complete.pm type=file
+c:\perl\lib/CPAN/Debug.pm type=file
+c:\perl\lib/CPAN/DeferredCode.pm type=file
+c:\perl\lib/CPAN/Distribution.pm type=file
+c:\perl\lib/CPAN/Distroprefs.pm type=file
+c:\perl\lib/CPAN/Distrostatus.pm type=file
+c:\perl\lib/CPAN/Exception/RecursiveDependency.pm type=file
+c:\perl\lib/CPAN/Exception/blocked_urllist.pm type=file
+c:\perl\lib/CPAN/Exception/yaml_not_installed.pm type=file
+c:\perl\lib/CPAN/FTP.pm type=file
+c:\perl\lib/CPAN/FTP/netrc.pm type=file
+c:\perl\lib/CPAN/FirstTime.pm type=file
+c:\perl\lib/CPAN/HandleConfig.pm type=file
+c:\perl\lib/CPAN/Index.pm type=file
+c:\perl\lib/CPAN/InfoObj.pm type=file
+c:\perl\lib/CPAN/Kwalify.pm type=file
+c:\perl\lib/CPAN/Kwalify/distroprefs.dd type=file
+c:\perl\lib/CPAN/Kwalify/distroprefs.yml type=file
+c:\perl\lib/CPAN/LWP/UserAgent.pm type=file
+c:\perl\lib/CPAN/Mirrors.pm type=file
+c:\perl\lib/CPAN/Module.pm type=file
+c:\perl\lib/CPAN/Nox.pm type=file
+c:\perl\lib/CPAN/Prompt.pm type=file
+c:\perl\lib/CPAN/Queue.pm type=file
+c:\perl\lib/CPAN/Shell.pm type=file
+c:\perl\lib/CPAN/Tarzip.pm type=file
+c:\perl\lib/CPAN/URL.pm type=file
+c:\perl\lib/CPAN/Version.pm type=file
+c:\perl\lib/CPANPLUS.pm type=file
+c:\perl\lib/CPANPLUS/Backend.pm type=file
+c:\perl\lib/CPANPLUS/Backend/RV.pm type=file
+c:\perl\lib/CPANPLUS/Config.pm type=file
+c:\perl\lib/CPANPLUS/Configure.pm type=file
+c:\perl\lib/CPANPLUS/Configure/Setup.pm type=file
+c:\perl\lib/CPANPLUS/Dist.pm type=file
+c:\perl\lib/CPANPLUS/Dist/Autobundle.pm type=file
+c:\perl\lib/CPANPLUS/Dist/Base.pm type=file
+c:\perl\lib/CPANPLUS/Dist/Build.pm type=file
+c:\perl\lib/CPANPLUS/Dist/Build/Constants.pm type=file
+c:\perl\lib/CPANPLUS/Dist/MM.pm type=file
+c:\perl\lib/CPANPLUS/Dist/Sample.pm type=file
+c:\perl\lib/CPANPLUS/Error.pm type=file
+c:\perl\lib/CPANPLUS/FAQ.pod type=file
+c:\perl\lib/CPANPLUS/Hacking.pod type=file
+c:\perl\lib/CPANPLUS/Internals.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Constants.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Constants/Report.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Extract.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Fetch.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Report.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Search.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Source.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Source/Memory.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Source/SQLite.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Source/SQLite/Tie.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Utils.pm type=file
+c:\perl\lib/CPANPLUS/Internals/Utils/Autoflush.pm type=file
+c:\perl\lib/CPANPLUS/Module.pm type=file
+c:\perl\lib/CPANPLUS/Module/Author.pm type=file
+c:\perl\lib/CPANPLUS/Module/Author/Fake.pm type=file
+c:\perl\lib/CPANPLUS/Module/Checksums.pm type=file
+c:\perl\lib/CPANPLUS/Module/Fake.pm type=file
+c:\perl\lib/CPANPLUS/Module/Signature.pm type=file
+c:\perl\lib/CPANPLUS/Selfupdate.pm type=file
+c:\perl\lib/CPANPLUS/Shell.pm type=file
+c:\perl\lib/CPANPLUS/Shell/Classic.pm type=file
+c:\perl\lib/CPANPLUS/Shell/Default.pm type=file
+c:\perl\lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm type=file
+c:\perl\lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod type=file
+c:\perl\lib/CPANPLUS/Shell/Default/Plugins/Remote.pm type=file
+c:\perl\lib/CPANPLUS/Shell/Default/Plugins/Source.pm type=file
+c:\perl\lib/Carp.pm type=file
+c:\perl\lib/Carp/Heavy.pm type=file
+c:\perl\lib/Class/ISA.pm type=file
+c:\perl\lib/Class/Struct.pm type=file
+c:\perl\lib/Compress/Raw/Bzip2.pm type=file
+c:\perl\lib/Compress/Raw/Zlib.pm type=file
+c:\perl\lib/Compress/Zlib.pm type=file
+c:\perl\lib/Config.pm type=file
+c:\perl\lib/Config.pod type=file
+c:\perl\lib/Config/Extensions.pm type=file
+c:\perl\lib/Config_git.pl type=file
+c:\perl\lib/Config_heavy.pl type=file
+c:\perl\lib/Cwd.pm type=file
+c:\perl\lib/DB.pm type=file
+c:\perl\lib/DBM_Filter.pm type=file
+c:\perl\lib/DBM_Filter/compress.pm type=file
+c:\perl\lib/DBM_Filter/encode.pm type=file
+c:\perl\lib/DBM_Filter/int32.pm type=file
+c:\perl\lib/DBM_Filter/null.pm type=file
+c:\perl\lib/DBM_Filter/utf8.pm type=file
+c:\perl\lib/Data/Dumper.pm type=file
+c:\perl\lib/Devel/DProf.pm type=file
+c:\perl\lib/Devel/DProf/V.pm type=file
+c:\perl\lib/Devel/DProf/test1_t type=file
+c:\perl\lib/Devel/DProf/test1_v type=file
+c:\perl\lib/Devel/DProf/test2_t type=file
+c:\perl\lib/Devel/DProf/test2_v type=file
+c:\perl\lib/Devel/DProf/test3_t type=file
+c:\perl\lib/Devel/DProf/test3_v type=file
+c:\perl\lib/Devel/DProf/test4_t type=file
+c:\perl\lib/Devel/DProf/test4_v type=file
+c:\perl\lib/Devel/DProf/test5_t type=file
+c:\perl\lib/Devel/DProf/test5_v type=file
+c:\perl\lib/Devel/DProf/test6_t type=file
+c:\perl\lib/Devel/DProf/test6_v type=file
+c:\perl\lib/Devel/DProf/test7_t type=file
+c:\perl\lib/Devel/DProf/test7_v type=file
+c:\perl\lib/Devel/DProf/test8_t type=file
+c:\perl\lib/Devel/DProf/test8_v type=file
+c:\perl\lib/Devel/InnerPackage.pm type=file
+c:\perl\lib/Devel/PPPort.pm type=file
+c:\perl\lib/Devel/Peek.pm type=file
+c:\perl\lib/Devel/SelfStubber.pm type=file
+c:\perl\lib/Digest.pm type=file
+c:\perl\lib/Digest/MD5.pm type=file
+c:\perl\lib/Digest/SHA.pm type=file
+c:\perl\lib/Digest/base.pm type=file
+c:\perl\lib/Digest/file.pm type=file
+c:\perl\lib/DirHandle.pm type=file
+c:\perl\lib/Dumpvalue.pm type=file
+c:\perl\lib/DynaLoader.pm type=file
+c:\perl\lib/Encode.pm type=file
+c:\perl\lib/Encode/Alias.pm type=file
+c:\perl\lib/Encode/Byte.pm type=file
+c:\perl\lib/Encode/CJKConstants.pm type=file
+c:\perl\lib/Encode/CN.pm type=file
+c:\perl\lib/Encode/CN/HZ.pm type=file
+c:\perl\lib/Encode/Changes.e2x type=file
+c:\perl\lib/Encode/Config.pm type=file
+c:\perl\lib/Encode/ConfigLocal_PM.e2x type=file
+c:\perl\lib/Encode/EBCDIC.pm type=file
+c:\perl\lib/Encode/Encoder.pm type=file
+c:\perl\lib/Encode/Encoding.pm type=file
+c:\perl\lib/Encode/GSM0338.pm type=file
+c:\perl\lib/Encode/Guess.pm type=file
+c:\perl\lib/Encode/JP.pm type=file
+c:\perl\lib/Encode/JP/H2Z.pm type=file
+c:\perl\lib/Encode/JP/JIS7.pm type=file
+c:\perl\lib/Encode/KR.pm type=file
+c:\perl\lib/Encode/KR/2022_KR.pm type=file
+c:\perl\lib/Encode/MIME/Header.pm type=file
+c:\perl\lib/Encode/MIME/Header/ISO_2022_JP.pm type=file
+c:\perl\lib/Encode/MIME/Name.pm type=file
+c:\perl\lib/Encode/Makefile_PL.e2x type=file
+c:\perl\lib/Encode/PerlIO.pod type=file
+c:\perl\lib/Encode/README.e2x type=file
+c:\perl\lib/Encode/Supported.pod type=file
+c:\perl\lib/Encode/Symbol.pm type=file
+c:\perl\lib/Encode/TW.pm type=file
+c:\perl\lib/Encode/Unicode.pm type=file
+c:\perl\lib/Encode/Unicode/UTF7.pm type=file
+c:\perl\lib/Encode/_PM.e2x type=file
+c:\perl\lib/Encode/_T.e2x type=file
+c:\perl\lib/Encode/encode.h type=file
+c:\perl\lib/English.pm type=file
+c:\perl\lib/Env.pm type=file
+c:\perl\lib/Errno.pm type=file
+c:\perl\lib/Exporter.pm type=file
+c:\perl\lib/Exporter/Heavy.pm type=file
+c:\perl\lib/ExtUtils/CBuilder.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Base.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/Unix.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/VMS.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/Windows.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/aix.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/cygwin.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/darwin.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/dec_osf.pm type=file
+c:\perl\lib/ExtUtils/CBuilder/Platform/os2.pm type=file
+c:\perl\lib/ExtUtils/Command.pm type=file
+c:\perl\lib/ExtUtils/Command/MM.pm type=file
+c:\perl\lib/ExtUtils/Constant.pm type=file
+c:\perl\lib/ExtUtils/Constant/Base.pm type=file
+c:\perl\lib/ExtUtils/Constant/ProxySubs.pm type=file
+c:\perl\lib/ExtUtils/Constant/Utils.pm type=file
+c:\perl\lib/ExtUtils/Constant/XS.pm type=file
+c:\perl\lib/ExtUtils/Embed.pm type=file
+c:\perl\lib/ExtUtils/Install.pm type=file
+c:\perl\lib/ExtUtils/Installed.pm type=file
+c:\perl\lib/ExtUtils/Liblist.pm type=file
+c:\perl\lib/ExtUtils/Liblist/Kid.pm type=file
+c:\perl\lib/ExtUtils/MANIFEST.SKIP type=file
+c:\perl\lib/ExtUtils/MM.pm type=file
+c:\perl\lib/ExtUtils/MM_AIX.pm type=file
+c:\perl\lib/ExtUtils/MM_Any.pm type=file
+c:\perl\lib/ExtUtils/MM_BeOS.pm type=file
+c:\perl\lib/ExtUtils/MM_Cygwin.pm type=file
+c:\perl\lib/ExtUtils/MM_DOS.pm type=file
+c:\perl\lib/ExtUtils/MM_Darwin.pm type=file
+c:\perl\lib/ExtUtils/MM_MacOS.pm type=file
+c:\perl\lib/ExtUtils/MM_NW5.pm type=file
+c:\perl\lib/ExtUtils/MM_OS2.pm type=file
+c:\perl\lib/ExtUtils/MM_QNX.pm type=file
+c:\perl\lib/ExtUtils/MM_UWIN.pm type=file
+c:\perl\lib/ExtUtils/MM_Unix.pm type=file
+c:\perl\lib/ExtUtils/MM_VMS.pm type=file
+c:\perl\lib/ExtUtils/MM_VOS.pm type=file
+c:\perl\lib/ExtUtils/MM_Win32.pm type=file
+c:\perl\lib/ExtUtils/MM_Win95.pm type=file
+c:\perl\lib/ExtUtils/MY.pm type=file
+c:\perl\lib/ExtUtils/MakeMaker.pm type=file
+c:\perl\lib/ExtUtils/MakeMaker/Config.pm type=file
+c:\perl\lib/ExtUtils/MakeMaker/FAQ.pod type=file
+c:\perl\lib/ExtUtils/MakeMaker/Tutorial.pod type=file
+c:\perl\lib/ExtUtils/Manifest.pm type=file
+c:\perl\lib/ExtUtils/Miniperl.pm type=file
+c:\perl\lib/ExtUtils/Mkbootstrap.pm type=file
+c:\perl\lib/ExtUtils/Mksymlists.pm type=file
+c:\perl\lib/ExtUtils/Packlist.pm type=file
+c:\perl\lib/ExtUtils/ParseXS.pm type=file
+c:\perl\lib/ExtUtils/testlib.pm type=file
+c:\perl\lib/ExtUtils/typemap type=file
+c:\perl\lib/ExtUtils/xsubpp type=file
+c:\perl\lib/Fatal.pm type=file
+c:\perl\lib/Fcntl.pm type=file
+c:\perl\lib/File/Basename.pm type=file
+c:\perl\lib/File/CheckTree.pm type=file
+c:\perl\lib/File/Compare.pm type=file
+c:\perl\lib/File/Copy.pm type=file
+c:\perl\lib/File/DosGlob.pm type=file
+c:\perl\lib/File/Fetch.pm type=file
+c:\perl\lib/File/Find.pm type=file
+c:\perl\lib/File/Glob.pm type=file
+c:\perl\lib/File/GlobMapper.pm type=file
+c:\perl\lib/File/Path.pm type=file
+c:\perl\lib/File/Spec.pm type=file
+c:\perl\lib/File/Spec/Cygwin.pm type=file
+c:\perl\lib/File/Spec/Epoc.pm type=file
+c:\perl\lib/File/Spec/Functions.pm type=file
+c:\perl\lib/File/Spec/Mac.pm type=file
+c:\perl\lib/File/Spec/OS2.pm type=file
+c:\perl\lib/File/Spec/Unix.pm type=file
+c:\perl\lib/File/Spec/VMS.pm type=file
+c:\perl\lib/File/Spec/Win32.pm type=file
+c:\perl\lib/File/Temp.pm type=file
+c:\perl\lib/File/stat.pm type=file
+c:\perl\lib/FileCache.pm type=file
+c:\perl\lib/FileHandle.pm type=file
+c:\perl\lib/Filter/Simple.pm type=file
+c:\perl\lib/Filter/Util/Call.pm type=file
+c:\perl\lib/FindBin.pm type=file
+c:\perl\lib/Getopt/Long.pm type=file
+c:\perl\lib/Getopt/Std.pm type=file
+c:\perl\lib/Hash/Util.pm type=file
+c:\perl\lib/Hash/Util/FieldHash.pm type=file
+c:\perl\lib/I18N/Collate.pm type=file
+c:\perl\lib/I18N/LangTags.pm type=file
+c:\perl\lib/I18N/LangTags/Detect.pm type=file
+c:\perl\lib/I18N/LangTags/List.pm type=file
+c:\perl\lib/IO.pm type=file
+c:\perl\lib/IO/Compress/Adapter/Bzip2.pm type=file
+c:\perl\lib/IO/Compress/Adapter/Deflate.pm type=file
+c:\perl\lib/IO/Compress/Adapter/Identity.pm type=file
+c:\perl\lib/IO/Compress/Base.pm type=file
+c:\perl\lib/IO/Compress/Base/Common.pm type=file
+c:\perl\lib/IO/Compress/Bzip2.pm type=file
+c:\perl\lib/IO/Compress/Deflate.pm type=file
+c:\perl\lib/IO/Compress/Gzip.pm type=file
+c:\perl\lib/IO/Compress/Gzip/Constants.pm type=file
+c:\perl\lib/IO/Compress/RawDeflate.pm type=file
+c:\perl\lib/IO/Compress/Zip.pm type=file
+c:\perl\lib/IO/Compress/Zip/Constants.pm type=file
+c:\perl\lib/IO/Compress/Zlib/Constants.pm type=file
+c:\perl\lib/IO/Compress/Zlib/Extra.pm type=file
+c:\perl\lib/IO/Dir.pm type=file
+c:\perl\lib/IO/File.pm type=file
+c:\perl\lib/IO/Handle.pm type=file
+c:\perl\lib/IO/Pipe.pm type=file
+c:\perl\lib/IO/Poll.pm type=file
+c:\perl\lib/IO/Seekable.pm type=file
+c:\perl\lib/IO/Select.pm type=file
+c:\perl\lib/IO/Socket.pm type=file
+c:\perl\lib/IO/Socket/INET.pm type=file
+c:\perl\lib/IO/Socket/UNIX.pm type=file
+c:\perl\lib/IO/Uncompress/Adapter/Bunzip2.pm type=file
+c:\perl\lib/IO/Uncompress/Adapter/Identity.pm type=file
+c:\perl\lib/IO/Uncompress/Adapter/Inflate.pm type=file
+c:\perl\lib/IO/Uncompress/AnyInflate.pm type=file
+c:\perl\lib/IO/Uncompress/AnyUncompress.pm type=file
+c:\perl\lib/IO/Uncompress/Base.pm type=file
+c:\perl\lib/IO/Uncompress/Bunzip2.pm type=file
+c:\perl\lib/IO/Uncompress/Gunzip.pm type=file
+c:\perl\lib/IO/Uncompress/Inflate.pm type=file
+c:\perl\lib/IO/Uncompress/RawInflate.pm type=file
+c:\perl\lib/IO/Uncompress/Unzip.pm type=file
+c:\perl\lib/IO/Zlib.pm type=file
+c:\perl\lib/IPC/Cmd.pm type=file
+c:\perl\lib/IPC/Open2.pm type=file
+c:\perl\lib/IPC/Open3.pm type=file
+c:\perl\lib/List/Util.pm type=file
+c:\perl\lib/List/Util/PP.pm type=file
+c:\perl\lib/List/Util/XS.pm type=file
+c:\perl\lib/Locale/Constants.pm type=file
+c:\perl\lib/Locale/Constants.pod type=file
+c:\perl\lib/Locale/Country.pm type=file
+c:\perl\lib/Locale/Country.pod type=file
+c:\perl\lib/Locale/Currency.pm type=file
+c:\perl\lib/Locale/Currency.pod type=file
+c:\perl\lib/Locale/Language.pm type=file
+c:\perl\lib/Locale/Language.pod type=file
+c:\perl\lib/Locale/Maketext.pm type=file
+c:\perl\lib/Locale/Maketext.pod type=file
+c:\perl\lib/Locale/Maketext/Guts.pm type=file
+c:\perl\lib/Locale/Maketext/GutsLoader.pm type=file
+c:\perl\lib/Locale/Maketext/Simple.pm type=file
+c:\perl\lib/Locale/Maketext/TPJ13.pod type=file
+c:\perl\lib/Locale/Script.pm type=file
+c:\perl\lib/Locale/Script.pod type=file
+c:\perl\lib/Log/Message.pm type=file
+c:\perl\lib/Log/Message/Config.pm type=file
+c:\perl\lib/Log/Message/Handlers.pm type=file
+c:\perl\lib/Log/Message/Item.pm type=file
+c:\perl\lib/Log/Message/Simple.pm type=file
+c:\perl\lib/MIME/Base64.pm type=file
+c:\perl\lib/MIME/QuotedPrint.pm type=file
+c:\perl\lib/Math/BigFloat.pm type=file
+c:\perl\lib/Math/BigFloat/Trace.pm type=file
+c:\perl\lib/Math/BigInt.pm type=file
+c:\perl\lib/Math/BigInt/Calc.pm type=file
+c:\perl\lib/Math/BigInt/CalcEmu.pm type=file
+c:\perl\lib/Math/BigInt/FastCalc.pm type=file
+c:\perl\lib/Math/BigInt/Trace.pm type=file
+c:\perl\lib/Math/BigRat.pm type=file
+c:\perl\lib/Math/Complex.pm type=file
+c:\perl\lib/Math/Trig.pm type=file
+c:\perl\lib/Memoize.pm type=file
+c:\perl\lib/Memoize/AnyDBM_File.pm type=file
+c:\perl\lib/Memoize/Expire.pm type=file
+c:\perl\lib/Memoize/ExpireFile.pm type=file
+c:\perl\lib/Memoize/ExpireTest.pm type=file
+c:\perl\lib/Memoize/NDBM_File.pm type=file
+c:\perl\lib/Memoize/SDBM_File.pm type=file
+c:\perl\lib/Memoize/Storable.pm type=file
+c:\perl\lib/Module/Build.pm type=file
+c:\perl\lib/Module/Build/API.pod type=file
+c:\perl\lib/Module/Build/Authoring.pod type=file
+c:\perl\lib/Module/Build/Base.pm type=file
+c:\perl\lib/Module/Build/Bundling.pod type=file
+c:\perl\lib/Module/Build/Compat.pm type=file
+c:\perl\lib/Module/Build/Config.pm type=file
+c:\perl\lib/Module/Build/ConfigData.pm type=file
+c:\perl\lib/Module/Build/Cookbook.pm type=file
+c:\perl\lib/Module/Build/Dumper.pm type=file
+c:\perl\lib/Module/Build/ModuleInfo.pm type=file
+c:\perl\lib/Module/Build/Notes.pm type=file
+c:\perl\lib/Module/Build/PPMMaker.pm type=file
+c:\perl\lib/Module/Build/Platform/Amiga.pm type=file
+c:\perl\lib/Module/Build/Platform/Default.pm type=file
+c:\perl\lib/Module/Build/Platform/EBCDIC.pm type=file
+c:\perl\lib/Module/Build/Platform/MPEiX.pm type=file
+c:\perl\lib/Module/Build/Platform/MacOS.pm type=file
+c:\perl\lib/Module/Build/Platform/RiscOS.pm type=file
+c:\perl\lib/Module/Build/Platform/Unix.pm type=file
+c:\perl\lib/Module/Build/Platform/VMS.pm type=file
+c:\perl\lib/Module/Build/Platform/VOS.pm type=file
+c:\perl\lib/Module/Build/Platform/Windows.pm type=file
+c:\perl\lib/Module/Build/Platform/aix.pm type=file
+c:\perl\lib/Module/Build/Platform/cygwin.pm type=file
+c:\perl\lib/Module/Build/Platform/darwin.pm type=file
+c:\perl\lib/Module/Build/Platform/os2.pm type=file
+c:\perl\lib/Module/Build/PodParser.pm type=file
+c:\perl\lib/Module/Build/Version.pm type=file
+c:\perl\lib/Module/Build/YAML.pm type=file
+c:\perl\lib/Module/CoreList.pm type=file
+c:\perl\lib/Module/Load.pm type=file
+c:\perl\lib/Module/Load/Conditional.pm type=file
+c:\perl\lib/Module/Loaded.pm type=file
+c:\perl\lib/Module/Pluggable.pm type=file
+c:\perl\lib/Module/Pluggable/Object.pm type=file
+c:\perl\lib/NEXT.pm type=file
+c:\perl\lib/Net/Cmd.pm type=file
+c:\perl\lib/Net/Config.pm type=file
+c:\perl\lib/Net/Domain.pm type=file
+c:\perl\lib/Net/FTP.pm type=file
+c:\perl\lib/Net/FTP/A.pm type=file
+c:\perl\lib/Net/FTP/E.pm type=file
+c:\perl\lib/Net/FTP/I.pm type=file
+c:\perl\lib/Net/FTP/L.pm type=file
+c:\perl\lib/Net/FTP/dataconn.pm type=file
+c:\perl\lib/Net/NNTP.pm type=file
+c:\perl\lib/Net/Netrc.pm type=file
+c:\perl\lib/Net/POP3.pm type=file
+c:\perl\lib/Net/Ping.pm type=file
+c:\perl\lib/Net/SMTP.pm type=file
+c:\perl\lib/Net/Time.pm type=file
+c:\perl\lib/Net/hostent.pm type=file
+c:\perl\lib/Net/libnetFAQ.pod type=file
+c:\perl\lib/Net/netent.pm type=file
+c:\perl\lib/Net/protoent.pm type=file
+c:\perl\lib/Net/servent.pm type=file
+c:\perl\lib/O.pm type=file
+c:\perl\lib/Object/Accessor.pm type=file
+c:\perl\lib/Opcode.pm type=file
+c:\perl\lib/POSIX.pm type=file
+c:\perl\lib/POSIX.pod type=file
+c:\perl\lib/Package/Constants.pm type=file
+c:\perl\lib/Params/Check.pm type=file
+c:\perl\lib/Parse/CPAN/Meta.pm type=file
+c:\perl\lib/PerlIO.pm type=file
+c:\perl\lib/PerlIO/encoding.pm type=file
+c:\perl\lib/PerlIO/scalar.pm type=file
+c:\perl\lib/PerlIO/via.pm type=file
+c:\perl\lib/PerlIO/via/QuotedPrint.pm type=file
+c:\perl\lib/Pod/Checker.pm type=file
+c:\perl\lib/Pod/Escapes.pm type=file
+c:\perl\lib/Pod/Find.pm type=file
+c:\perl\lib/Pod/Functions.pm type=file
+c:\perl\lib/Pod/Html.pm type=file
+c:\perl\lib/Pod/InputObjects.pm type=file
+c:\perl\lib/Pod/LaTeX.pm type=file
+c:\perl\lib/Pod/Man.pm type=file
+c:\perl\lib/Pod/ParseLink.pm type=file
+c:\perl\lib/Pod/ParseUtils.pm type=file
+c:\perl\lib/Pod/Parser.pm type=file
+c:\perl\lib/Pod/Perldoc.pm type=file
+c:\perl\lib/Pod/Perldoc/BaseTo.pm type=file
+c:\perl\lib/Pod/Perldoc/GetOptsOO.pm type=file
+c:\perl\lib/Pod/Perldoc/ToChecker.pm type=file
+c:\perl\lib/Pod/Perldoc/ToMan.pm type=file
+c:\perl\lib/Pod/Perldoc/ToNroff.pm type=file
+c:\perl\lib/Pod/Perldoc/ToPod.pm type=file
+c:\perl\lib/Pod/Perldoc/ToRtf.pm type=file
+c:\perl\lib/Pod/Perldoc/ToText.pm type=file
+c:\perl\lib/Pod/Perldoc/ToTk.pm type=file
+c:\perl\lib/Pod/Perldoc/ToXml.pm type=file
+c:\perl\lib/Pod/PlainText.pm type=file
+c:\perl\lib/Pod/Plainer.pm type=file
+c:\perl\lib/Pod/Select.pm type=file
+c:\perl\lib/Pod/Simple.pm type=file
+c:\perl\lib/Pod/Simple.pod type=file
+c:\perl\lib/Pod/Simple/BlackBox.pm type=file
+c:\perl\lib/Pod/Simple/Checker.pm type=file
+c:\perl\lib/Pod/Simple/Debug.pm type=file
+c:\perl\lib/Pod/Simple/DumpAsText.pm type=file
+c:\perl\lib/Pod/Simple/DumpAsXML.pm type=file
+c:\perl\lib/Pod/Simple/HTML.pm type=file
+c:\perl\lib/Pod/Simple/HTMLBatch.pm type=file
+c:\perl\lib/Pod/Simple/HTMLLegacy.pm type=file
+c:\perl\lib/Pod/Simple/LinkSection.pm type=file
+c:\perl\lib/Pod/Simple/Methody.pm type=file
+c:\perl\lib/Pod/Simple/Progress.pm type=file
+c:\perl\lib/Pod/Simple/PullParser.pm type=file
+c:\perl\lib/Pod/Simple/PullParserEndToken.pm type=file
+c:\perl\lib/Pod/Simple/PullParserStartToken.pm type=file
+c:\perl\lib/Pod/Simple/PullParserTextToken.pm type=file
+c:\perl\lib/Pod/Simple/PullParserToken.pm type=file
+c:\perl\lib/Pod/Simple/RTF.pm type=file
+c:\perl\lib/Pod/Simple/Search.pm type=file
+c:\perl\lib/Pod/Simple/SimpleTree.pm type=file
+c:\perl\lib/Pod/Simple/Subclassing.pod type=file
+c:\perl\lib/Pod/Simple/Text.pm type=file
+c:\perl\lib/Pod/Simple/TextContent.pm type=file
+c:\perl\lib/Pod/Simple/TiedOutFH.pm type=file
+c:\perl\lib/Pod/Simple/Transcode.pm type=file
+c:\perl\lib/Pod/Simple/TranscodeDumb.pm type=file
+c:\perl\lib/Pod/Simple/TranscodeSmart.pm type=file
+c:\perl\lib/Pod/Simple/XHTML.pm type=file
+c:\perl\lib/Pod/Simple/XMLOutStream.pm type=file
+c:\perl\lib/Pod/Text.pm type=file
+c:\perl\lib/Pod/Text/Color.pm type=file
+c:\perl\lib/Pod/Text/Overstrike.pm type=file
+c:\perl\lib/Pod/Text/Termcap.pm type=file
+c:\perl\lib/Pod/Usage.pm type=file
+c:\perl\lib/SDBM_File.pm type=file
+c:\perl\lib/Safe.pm type=file
+c:\perl\lib/Scalar/Util.pm type=file
+c:\perl\lib/Scalar/Util/PP.pm type=file
+c:\perl\lib/Search/Dict.pm type=file
+c:\perl\lib/SelectSaver.pm type=file
+c:\perl\lib/SelfLoader.pm type=file
+c:\perl\lib/Shell.pm type=file
+c:\perl\lib/Socket.pm type=file
+c:\perl\lib/Storable.pm type=file
+c:\perl\lib/Switch.pm type=file
+c:\perl\lib/Symbol.pm type=file
+c:\perl\lib/Sys/Hostname.pm type=file
+c:\perl\lib/TAP/Base.pm type=file
+c:\perl\lib/TAP/Formatter/Base.pm type=file
+c:\perl\lib/TAP/Formatter/Color.pm type=file
+c:\perl\lib/TAP/Formatter/Console.pm type=file
+c:\perl\lib/TAP/Formatter/Console/ParallelSession.pm type=file
+c:\perl\lib/TAP/Formatter/Console/Session.pm type=file
+c:\perl\lib/TAP/Formatter/File.pm type=file
+c:\perl\lib/TAP/Formatter/File/Session.pm type=file
+c:\perl\lib/TAP/Formatter/Session.pm type=file
+c:\perl\lib/TAP/Harness.pm type=file
+c:\perl\lib/TAP/Object.pm type=file
+c:\perl\lib/TAP/Parser.pm type=file
+c:\perl\lib/TAP/Parser/Aggregator.pm type=file
+c:\perl\lib/TAP/Parser/Grammar.pm type=file
+c:\perl\lib/TAP/Parser/Iterator.pm type=file
+c:\perl\lib/TAP/Parser/Iterator/Array.pm type=file
+c:\perl\lib/TAP/Parser/Iterator/Process.pm type=file
+c:\perl\lib/TAP/Parser/Iterator/Stream.pm type=file
+c:\perl\lib/TAP/Parser/IteratorFactory.pm type=file
+c:\perl\lib/TAP/Parser/Multiplexer.pm type=file
+c:\perl\lib/TAP/Parser/Result.pm type=file
+c:\perl\lib/TAP/Parser/Result/Bailout.pm type=file
+c:\perl\lib/TAP/Parser/Result/Comment.pm type=file
+c:\perl\lib/TAP/Parser/Result/Plan.pm type=file
+c:\perl\lib/TAP/Parser/Result/Pragma.pm type=file
+c:\perl\lib/TAP/Parser/Result/Test.pm type=file
+c:\perl\lib/TAP/Parser/Result/Unknown.pm type=file
+c:\perl\lib/TAP/Parser/Result/Version.pm type=file
+c:\perl\lib/TAP/Parser/Result/YAML.pm type=file
+c:\perl\lib/TAP/Parser/ResultFactory.pm type=file
+c:\perl\lib/TAP/Parser/Scheduler.pm type=file
+c:\perl\lib/TAP/Parser/Scheduler/Job.pm type=file
+c:\perl\lib/TAP/Parser/Scheduler/Spinner.pm type=file
+c:\perl\lib/TAP/Parser/Source.pm type=file
+c:\perl\lib/TAP/Parser/Source/Perl.pm type=file
+c:\perl\lib/TAP/Parser/Utils.pm type=file
+c:\perl\lib/TAP/Parser/YAMLish/Reader.pm type=file
+c:\perl\lib/TAP/Parser/YAMLish/Writer.pm type=file
+c:\perl\lib/Term/ANSIColor.pm type=file
+c:\perl\lib/Term/Cap.pm type=file
+c:\perl\lib/Term/Complete.pm type=file
+c:\perl\lib/Term/ReadLine.pm type=file
+c:\perl\lib/Term/UI.pm type=file
+c:\perl\lib/Term/UI/History.pm type=file
+c:\perl\lib/Test.pm type=file
+c:\perl\lib/Test/Builder.pm type=file
+c:\perl\lib/Test/Builder/Module.pm type=file
+c:\perl\lib/Test/Builder/Tester.pm type=file
+c:\perl\lib/Test/Builder/Tester/Color.pm type=file
+c:\perl\lib/Test/Harness.pm type=file
+c:\perl\lib/Test/More.pm type=file
+c:\perl\lib/Test/Simple.pm type=file
+c:\perl\lib/Test/Tutorial.pod type=file
+c:\perl\lib/Text/Abbrev.pm type=file
+c:\perl\lib/Text/Balanced.pm type=file
+c:\perl\lib/Text/ParseWords.pm type=file
+c:\perl\lib/Text/Soundex.pm type=file
+c:\perl\lib/Text/Tabs.pm type=file
+c:\perl\lib/Text/Wrap.pm type=file
+c:\perl\lib/Thread.pm type=file
+c:\perl\lib/Thread/Queue.pm type=file
+c:\perl\lib/Thread/Semaphore.pm type=file
+c:\perl\lib/Tie/Array.pm type=file
+c:\perl\lib/Tie/File.pm type=file
+c:\perl\lib/Tie/Handle.pm type=file
+c:\perl\lib/Tie/Hash.pm type=file
+c:\perl\lib/Tie/Hash/NamedCapture.pm type=file
+c:\perl\lib/Tie/Memoize.pm type=file
+c:\perl\lib/Tie/RefHash.pm type=file
+c:\perl\lib/Tie/Scalar.pm type=file
+c:\perl\lib/Tie/StdHandle.pm type=file
+c:\perl\lib/Tie/SubstrHash.pm type=file
+c:\perl\lib/Time/HiRes.pm type=file
+c:\perl\lib/Time/Local.pm type=file
+c:\perl\lib/Time/Piece.pm type=file
+c:\perl\lib/Time/Seconds.pm type=file
+c:\perl\lib/Time/gmtime.pm type=file
+c:\perl\lib/Time/localtime.pm type=file
+c:\perl\lib/Time/tm.pm type=file
+c:\perl\lib/UNIVERSAL.pm type=file
+c:\perl\lib/Unicode/Collate.pm type=file
+c:\perl\lib/Unicode/Collate/allkeys.txt type=file
+c:\perl\lib/Unicode/Collate/keys.txt type=file
+c:\perl\lib/Unicode/Normalize.pm type=file
+c:\perl\lib/Unicode/UCD.pm type=file
+c:\perl\lib/User/grent.pm type=file
+c:\perl\lib/User/pwent.pm type=file
+c:\perl\lib/Win32.pm type=file
+c:\perl\lib/Win32API/File.pm type=file
+c:\perl\lib/Win32API/File/cFile.pc type=file
+c:\perl\lib/Win32CORE.pm type=file
+c:\perl\lib/XSLoader.pm type=file
+c:\perl\lib/abbrev.pl type=file
+c:\perl\lib/assert.pl type=file
+c:\perl\lib/attributes.pm type=file
+c:\perl\lib/auto/B/B.dll type=file
+c:\perl\lib/auto/Compress/Raw/Bzip2/Bzip2.dll type=file
+c:\perl\lib/auto/Compress/Raw/Bzip2/autosplit.ix type=file
+c:\perl\lib/auto/Compress/Raw/Zlib/Zlib.dll type=file
+c:\perl\lib/auto/Compress/Raw/Zlib/autosplit.ix type=file
+c:\perl\lib/auto/Compress/Zlib/autosplit.ix type=file
+c:\perl\lib/auto/Cwd/Cwd.dll type=file
+c:\perl\lib/auto/Data/Dumper/Dumper.dll type=file
+c:\perl\lib/auto/Devel/DProf/DProf.dll type=file
+c:\perl\lib/auto/Devel/PPPort/PPPort.dll type=file
+c:\perl\lib/auto/Devel/Peek/Peek.dll type=file
+c:\perl\lib/auto/Digest/MD5/MD5.dll type=file
+c:\perl\lib/auto/Digest/SHA/SHA.dll type=file
+c:\perl\lib/auto/DynaLoader/autosplit.ix type=file
+c:\perl\lib/auto/DynaLoader/dl_expandspec.al type=file
+c:\perl\lib/auto/DynaLoader/dl_find_symbol_anywhere.al type=file
+c:\perl\lib/auto/DynaLoader/dl_findfile.al type=file
+c:\perl\lib/auto/Encode/Byte/Byte.dll type=file
+c:\perl\lib/auto/Encode/CN/CN.dll type=file
+c:\perl\lib/auto/Encode/EBCDIC/EBCDIC.dll type=file
+c:\perl\lib/auto/Encode/Encode.dll type=file
+c:\perl\lib/auto/Encode/JP/JP.dll type=file
+c:\perl\lib/auto/Encode/KR/KR.dll type=file
+c:\perl\lib/auto/Encode/Symbol/Symbol.dll type=file
+c:\perl\lib/auto/Encode/TW/TW.dll type=file
+c:\perl\lib/auto/Encode/Unicode/Unicode.dll type=file
+c:\perl\lib/auto/Fcntl/Fcntl.dll type=file
+c:\perl\lib/auto/File/Glob/Glob.dll type=file
+c:\perl\lib/auto/Filter/Util/Call/Call.dll type=file
+c:\perl\lib/auto/Hash/Util/FieldHash/FieldHash.dll type=file
+c:\perl\lib/auto/Hash/Util/Util.dll type=file
+c:\perl\lib/auto/IO/IO.dll type=file
+c:\perl\lib/auto/List/Util/Util.dll type=file
+c:\perl\lib/auto/MIME/Base64/Base64.dll type=file
+c:\perl\lib/auto/Math/BigInt/FastCalc/FastCalc.dll type=file
+c:\perl\lib/auto/Opcode/Opcode.dll type=file
+c:\perl\lib/auto/POSIX/POSIX.dll type=file
+c:\perl\lib/auto/POSIX/SigAction/flags.al type=file
+c:\perl\lib/auto/POSIX/SigAction/handler.al type=file
+c:\perl\lib/auto/POSIX/SigAction/mask.al type=file
+c:\perl\lib/auto/POSIX/SigAction/new.al type=file
+c:\perl\lib/auto/POSIX/SigAction/safe.al type=file
+c:\perl\lib/auto/POSIX/SigRt/CLEAR.al type=file
+c:\perl\lib/auto/POSIX/SigRt/DELETE.al type=file
+c:\perl\lib/auto/POSIX/SigRt/EXISTS.al type=file
+c:\perl\lib/auto/POSIX/SigRt/FETCH.al type=file
+c:\perl\lib/auto/POSIX/SigRt/SCALAR.al type=file
+c:\perl\lib/auto/POSIX/SigRt/STORE.al type=file
+c:\perl\lib/auto/POSIX/SigRt/_check.al type=file
+c:\perl\lib/auto/POSIX/SigRt/_croak.al type=file
+c:\perl\lib/auto/POSIX/SigRt/_exist.al type=file
+c:\perl\lib/auto/POSIX/SigRt/_getsig.al type=file
+c:\perl\lib/auto/POSIX/SigRt/_init.al type=file
+c:\perl\lib/auto/POSIX/SigRt/new.al type=file
+c:\perl\lib/auto/POSIX/abs.al type=file
+c:\perl\lib/auto/POSIX/alarm.al type=file
+c:\perl\lib/auto/POSIX/assert.al type=file
+c:\perl\lib/auto/POSIX/atan2.al type=file
+c:\perl\lib/auto/POSIX/atexit.al type=file
+c:\perl\lib/auto/POSIX/atof.al type=file
+c:\perl\lib/auto/POSIX/atoi.al type=file
+c:\perl\lib/auto/POSIX/atol.al type=file
+c:\perl\lib/auto/POSIX/autosplit.ix type=file
+c:\perl\lib/auto/POSIX/bsearch.al type=file
+c:\perl\lib/auto/POSIX/calloc.al type=file
+c:\perl\lib/auto/POSIX/chdir.al type=file
+c:\perl\lib/auto/POSIX/chmod.al type=file
+c:\perl\lib/auto/POSIX/chown.al type=file
+c:\perl\lib/auto/POSIX/clearerr.al type=file
+c:\perl\lib/auto/POSIX/closedir.al type=file
+c:\perl\lib/auto/POSIX/cos.al type=file
+c:\perl\lib/auto/POSIX/creat.al type=file
+c:\perl\lib/auto/POSIX/div.al type=file
+c:\perl\lib/auto/POSIX/errno.al type=file
+c:\perl\lib/auto/POSIX/execl.al type=file
+c:\perl\lib/auto/POSIX/execle.al type=file
+c:\perl\lib/auto/POSIX/execlp.al type=file
+c:\perl\lib/auto/POSIX/execv.al type=file
+c:\perl\lib/auto/POSIX/execve.al type=file
+c:\perl\lib/auto/POSIX/execvp.al type=file
+c:\perl\lib/auto/POSIX/exit.al type=file
+c:\perl\lib/auto/POSIX/exp.al type=file
+c:\perl\lib/auto/POSIX/fabs.al type=file
+c:\perl\lib/auto/POSIX/fclose.al type=file
+c:\perl\lib/auto/POSIX/fcntl.al type=file
+c:\perl\lib/auto/POSIX/fdopen.al type=file
+c:\perl\lib/auto/POSIX/feof.al type=file
+c:\perl\lib/auto/POSIX/ferror.al type=file
+c:\perl\lib/auto/POSIX/fflush.al type=file
+c:\perl\lib/auto/POSIX/fgetc.al type=file
+c:\perl\lib/auto/POSIX/fgetpos.al type=file
+c:\perl\lib/auto/POSIX/fgets.al type=file
+c:\perl\lib/auto/POSIX/fileno.al type=file
+c:\perl\lib/auto/POSIX/fopen.al type=file
+c:\perl\lib/auto/POSIX/fork.al type=file
+c:\perl\lib/auto/POSIX/fprintf.al type=file
+c:\perl\lib/auto/POSIX/fputc.al type=file
+c:\perl\lib/auto/POSIX/fputs.al type=file
+c:\perl\lib/auto/POSIX/fread.al type=file
+c:\perl\lib/auto/POSIX/free.al type=file
+c:\perl\lib/auto/POSIX/freopen.al type=file
+c:\perl\lib/auto/POSIX/fscanf.al type=file
+c:\perl\lib/auto/POSIX/fseek.al type=file
+c:\perl\lib/auto/POSIX/fsetpos.al type=file
+c:\perl\lib/auto/POSIX/fstat.al type=file
+c:\perl\lib/auto/POSIX/fsync.al type=file
+c:\perl\lib/auto/POSIX/ftell.al type=file
+c:\perl\lib/auto/POSIX/fwrite.al type=file
+c:\perl\lib/auto/POSIX/getc.al type=file
+c:\perl\lib/auto/POSIX/getchar.al type=file
+c:\perl\lib/auto/POSIX/getegid.al type=file
+c:\perl\lib/auto/POSIX/getenv.al type=file
+c:\perl\lib/auto/POSIX/geteuid.al type=file
+c:\perl\lib/auto/POSIX/getgid.al type=file
+c:\perl\lib/auto/POSIX/getgrgid.al type=file
+c:\perl\lib/auto/POSIX/getgrnam.al type=file
+c:\perl\lib/auto/POSIX/getgroups.al type=file
+c:\perl\lib/auto/POSIX/getlogin.al type=file
+c:\perl\lib/auto/POSIX/getpgrp.al type=file
+c:\perl\lib/auto/POSIX/getpid.al type=file
+c:\perl\lib/auto/POSIX/getppid.al type=file
+c:\perl\lib/auto/POSIX/getpwnam.al type=file
+c:\perl\lib/auto/POSIX/getpwuid.al type=file
+c:\perl\lib/auto/POSIX/gets.al type=file
+c:\perl\lib/auto/POSIX/getuid.al type=file
+c:\perl\lib/auto/POSIX/gmtime.al type=file
+c:\perl\lib/auto/POSIX/isatty.al type=file
+c:\perl\lib/auto/POSIX/kill.al type=file
+c:\perl\lib/auto/POSIX/labs.al type=file
+c:\perl\lib/auto/POSIX/ldiv.al type=file
+c:\perl\lib/auto/POSIX/link.al type=file
+c:\perl\lib/auto/POSIX/load_imports.al type=file
+c:\perl\lib/auto/POSIX/localtime.al type=file
+c:\perl\lib/auto/POSIX/log.al type=file
+c:\perl\lib/auto/POSIX/longjmp.al type=file
+c:\perl\lib/auto/POSIX/malloc.al type=file
+c:\perl\lib/auto/POSIX/memchr.al type=file
+c:\perl\lib/auto/POSIX/memcmp.al type=file
+c:\perl\lib/auto/POSIX/memcpy.al type=file
+c:\perl\lib/auto/POSIX/memmove.al type=file
+c:\perl\lib/auto/POSIX/memset.al type=file
+c:\perl\lib/auto/POSIX/mkdir.al type=file
+c:\perl\lib/auto/POSIX/offsetof.al type=file
+c:\perl\lib/auto/POSIX/opendir.al type=file
+c:\perl\lib/auto/POSIX/perror.al type=file
+c:\perl\lib/auto/POSIX/pow.al type=file
+c:\perl\lib/auto/POSIX/printf.al type=file
+c:\perl\lib/auto/POSIX/putc.al type=file
+c:\perl\lib/auto/POSIX/putchar.al type=file
+c:\perl\lib/auto/POSIX/puts.al type=file
+c:\perl\lib/auto/POSIX/qsort.al type=file
+c:\perl\lib/auto/POSIX/raise.al type=file
+c:\perl\lib/auto/POSIX/rand.al type=file
+c:\perl\lib/auto/POSIX/readdir.al type=file
+c:\perl\lib/auto/POSIX/realloc.al type=file
+c:\perl\lib/auto/POSIX/redef.al type=file
+c:\perl\lib/auto/POSIX/remove.al type=file
+c:\perl\lib/auto/POSIX/rename.al type=file
+c:\perl\lib/auto/POSIX/rewind.al type=file
+c:\perl\lib/auto/POSIX/rewinddir.al type=file
+c:\perl\lib/auto/POSIX/rmdir.al type=file
+c:\perl\lib/auto/POSIX/scanf.al type=file
+c:\perl\lib/auto/POSIX/setbuf.al type=file
+c:\perl\lib/auto/POSIX/setjmp.al type=file
+c:\perl\lib/auto/POSIX/setvbuf.al type=file
+c:\perl\lib/auto/POSIX/siglongjmp.al type=file
+c:\perl\lib/auto/POSIX/sigsetjmp.al type=file
+c:\perl\lib/auto/POSIX/sin.al type=file
+c:\perl\lib/auto/POSIX/sleep.al type=file
+c:\perl\lib/auto/POSIX/sprintf.al type=file
+c:\perl\lib/auto/POSIX/sqrt.al type=file
+c:\perl\lib/auto/POSIX/srand.al type=file
+c:\perl\lib/auto/POSIX/sscanf.al type=file
+c:\perl\lib/auto/POSIX/stat.al type=file
+c:\perl\lib/auto/POSIX/strcat.al type=file
+c:\perl\lib/auto/POSIX/strchr.al type=file
+c:\perl\lib/auto/POSIX/strcmp.al type=file
+c:\perl\lib/auto/POSIX/strcpy.al type=file
+c:\perl\lib/auto/POSIX/strcspn.al type=file
+c:\perl\lib/auto/POSIX/strerror.al type=file
+c:\perl\lib/auto/POSIX/strlen.al type=file
+c:\perl\lib/auto/POSIX/strncat.al type=file
+c:\perl\lib/auto/POSIX/strncmp.al type=file
+c:\perl\lib/auto/POSIX/strncpy.al type=file
+c:\perl\lib/auto/POSIX/strpbrk.al type=file
+c:\perl\lib/auto/POSIX/strrchr.al type=file
+c:\perl\lib/auto/POSIX/strspn.al type=file
+c:\perl\lib/auto/POSIX/strstr.al type=file
+c:\perl\lib/auto/POSIX/strtok.al type=file
+c:\perl\lib/auto/POSIX/system.al type=file
+c:\perl\lib/auto/POSIX/time.al type=file
+c:\perl\lib/auto/POSIX/tmpfile.al type=file
+c:\perl\lib/auto/POSIX/tolower.al type=file
+c:\perl\lib/auto/POSIX/toupper.al type=file
+c:\perl\lib/auto/POSIX/umask.al type=file
+c:\perl\lib/auto/POSIX/ungetc.al type=file
+c:\perl\lib/auto/POSIX/unimpl.al type=file
+c:\perl\lib/auto/POSIX/unlink.al type=file
+c:\perl\lib/auto/POSIX/usage.al type=file
+c:\perl\lib/auto/POSIX/utime.al type=file
+c:\perl\lib/auto/POSIX/vfprintf.al type=file
+c:\perl\lib/auto/POSIX/vprintf.al type=file
+c:\perl\lib/auto/POSIX/vsprintf.al type=file
+c:\perl\lib/auto/POSIX/wait.al type=file
+c:\perl\lib/auto/POSIX/waitpid.al type=file
+c:\perl\lib/auto/PerlIO/encoding/encoding.dll type=file
+c:\perl\lib/auto/PerlIO/scalar/scalar.dll type=file
+c:\perl\lib/auto/PerlIO/via/via.dll type=file
+c:\perl\lib/auto/SDBM_File/SDBM_File.dll type=file
+c:\perl\lib/auto/Socket/Socket.dll type=file
+c:\perl\lib/auto/Storable/BIN_VERSION_NV.al type=file
+c:\perl\lib/auto/Storable/BIN_WRITE_VERSION_NV.al type=file
+c:\perl\lib/auto/Storable/CAN_FLOCK.al type=file
+c:\perl\lib/auto/Storable/Storable.dll type=file
+c:\perl\lib/auto/Storable/_freeze.al type=file
+c:\perl\lib/auto/Storable/_retrieve.al type=file
+c:\perl\lib/auto/Storable/_store.al type=file
+c:\perl\lib/auto/Storable/_store_fd.al type=file
+c:\perl\lib/auto/Storable/autosplit.ix type=file
+c:\perl\lib/auto/Storable/fd_retrieve.al type=file
+c:\perl\lib/auto/Storable/file_magic.al type=file
+c:\perl\lib/auto/Storable/freeze.al type=file
+c:\perl\lib/auto/Storable/lock_nstore.al type=file
+c:\perl\lib/auto/Storable/lock_retrieve.al type=file
+c:\perl\lib/auto/Storable/lock_store.al type=file
+c:\perl\lib/auto/Storable/logcarp.al type=file
+c:\perl\lib/auto/Storable/logcroak.al type=file
+c:\perl\lib/auto/Storable/nfreeze.al type=file
+c:\perl\lib/auto/Storable/nstore.al type=file
+c:\perl\lib/auto/Storable/nstore_fd.al type=file
+c:\perl\lib/auto/Storable/read_magic.al type=file
+c:\perl\lib/auto/Storable/retrieve.al type=file
+c:\perl\lib/auto/Storable/show_file_magic.al type=file
+c:\perl\lib/auto/Storable/store.al type=file
+c:\perl\lib/auto/Storable/store_fd.al type=file
+c:\perl\lib/auto/Storable/thaw.al type=file
+c:\perl\lib/auto/Sys/Hostname/Hostname.dll type=file
+c:\perl\lib/auto/Sys/Hostname/autosplit.ix type=file
+c:\perl\lib/auto/Text/Soundex/Soundex.dll type=file
+c:\perl\lib/auto/Time/HiRes/HiRes.dll type=file
+c:\perl\lib/auto/Time/Piece/Piece.dll type=file
+c:\perl\lib/auto/Unicode/Normalize/Normalize.dll type=file
+c:\perl\lib/auto/Win32/Win32.dll type=file
+c:\perl\lib/auto/Win32API/File/File.dll type=file
+c:\perl\lib/auto/Win32CORE/extralibs.ld type=file
+c:\perl\lib/auto/attributes/attributes.dll type=file
+c:\perl\lib/auto/mro/mro.dll type=file
+c:\perl\lib/auto/re/re.dll type=file
+c:\perl\lib/auto/sdbm/extralibs.ld type=file
+c:\perl\lib/auto/threads/shared/shared.dll type=file
+c:\perl\lib/auto/threads/threads.dll type=file
+c:\perl\lib/autodie.pm type=file
+c:\perl\lib/autodie/exception.pm type=file
+c:\perl\lib/autodie/exception/system.pm type=file
+c:\perl\lib/autodie/hints.pm type=file
+c:\perl\lib/autouse.pm type=file
+c:\perl\lib/base.pm type=file
+c:\perl\lib/bigfloat.pl type=file
+c:\perl\lib/bigint.pl type=file
+c:\perl\lib/bigint.pm type=file
+c:\perl\lib/bignum.pm type=file
+c:\perl\lib/bigrat.pl type=file
+c:\perl\lib/bigrat.pm type=file
+c:\perl\lib/blib.pm type=file
+c:\perl\lib/bytes.pm type=file
+c:\perl\lib/bytes_heavy.pl type=file
+c:\perl\lib/cacheout.pl type=file
+c:\perl\lib/charnames.pm type=file
+c:\perl\lib/complete.pl type=file
+c:\perl\lib/constant.pm type=file
+c:\perl\lib/ctime.pl type=file
+c:\perl\lib/deprecate.pm type=file
+c:\perl\lib/diagnostics.pm type=file
+c:\perl\lib/dotsh.pl type=file
+c:\perl\lib/dumpvar.pl type=file
+c:\perl\lib/encoding.pm type=file
+c:\perl\lib/encoding/warnings.pm type=file
+c:\perl\lib/exceptions.pl type=file
+c:\perl\lib/fastcwd.pl type=file
+c:\perl\lib/feature.pm type=file
+c:\perl\lib/fields.pm type=file
+c:\perl\lib/filetest.pm type=file
+c:\perl\lib/find.pl type=file
+c:\perl\lib/finddepth.pl type=file
+c:\perl\lib/flush.pl type=file
+c:\perl\lib/getcwd.pl type=file
+c:\perl\lib/getopt.pl type=file
+c:\perl\lib/getopts.pl type=file
+c:\perl\lib/hostname.pl type=file
+c:\perl\lib/if.pm type=file
+c:\perl\lib/importenv.pl type=file
+c:\perl\lib/inc/latest.pm type=file
+c:\perl\lib/inc/latest/private.pm type=file
+c:\perl\lib/integer.pm type=file
+c:\perl\lib/less.pm type=file
+c:\perl\lib/lib.pm type=file
+c:\perl\lib/locale.pm type=file
+c:\perl\lib/look.pl type=file
+c:\perl\lib/mro.pm type=file
+c:\perl\lib/newgetopt.pl type=file
+c:\perl\lib/open.pm type=file
+c:\perl\lib/open2.pl type=file
+c:\perl\lib/open3.pl type=file
+c:\perl\lib/ops.pm type=file
+c:\perl\lib/overload.pm type=file
+c:\perl\lib/overload/numbers.pm type=file
+c:\perl\lib/overloading.pm type=file
+c:\perl\lib/parent.pm type=file
+c:\perl\lib/perl5db.pl type=file
+c:\perl\lib/pods/a2p.pod type=file
+c:\perl\lib/pods/perl.pod type=file
+c:\perl\lib/pods/perl5004delta.pod type=file
+c:\perl\lib/pods/perl5005delta.pod type=file
+c:\perl\lib/pods/perl5100delta.pod type=file
+c:\perl\lib/pods/perl5101delta.pod type=file
+c:\perl\lib/pods/perl5110delta.pod type=file
+c:\perl\lib/pods/perl5111delta.pod type=file
+c:\perl\lib/pods/perl5112delta.pod type=file
+c:\perl\lib/pods/perl5113delta.pod type=file
+c:\perl\lib/pods/perl5114delta.pod type=file
+c:\perl\lib/pods/perl5115delta.pod type=file
+c:\perl\lib/pods/perl5120delta.pod type=file
+c:\perl\lib/pods/perl5121delta.pod type=file
+c:\perl\lib/pods/perl5122delta.pod type=file
+c:\perl\lib/pods/perl5123delta.pod type=file
+c:\perl\lib/pods/perl561delta.pod type=file
+c:\perl\lib/pods/perl56delta.pod type=file
+c:\perl\lib/pods/perl570delta.pod type=file
+c:\perl\lib/pods/perl571delta.pod type=file
+c:\perl\lib/pods/perl572delta.pod type=file
+c:\perl\lib/pods/perl573delta.pod type=file
+c:\perl\lib/pods/perl581delta.pod type=file
+c:\perl\lib/pods/perl582delta.pod type=file
+c:\perl\lib/pods/perl583delta.pod type=file
+c:\perl\lib/pods/perl584delta.pod type=file
+c:\perl\lib/pods/perl585delta.pod type=file
+c:\perl\lib/pods/perl586delta.pod type=file
+c:\perl\lib/pods/perl587delta.pod type=file
+c:\perl\lib/pods/perl588delta.pod type=file
+c:\perl\lib/pods/perl589delta.pod type=file
+c:\perl\lib/pods/perl58delta.pod type=file
+c:\perl\lib/pods/perl590delta.pod type=file
+c:\perl\lib/pods/perl591delta.pod type=file
+c:\perl\lib/pods/perl592delta.pod type=file
+c:\perl\lib/pods/perl593delta.pod type=file
+c:\perl\lib/pods/perl594delta.pod type=file
+c:\perl\lib/pods/perl595delta.pod type=file
+c:\perl\lib/pods/perlaix.pod type=file
+c:\perl\lib/pods/perlamiga.pod type=file
+c:\perl\lib/pods/perlapi.pod type=file
+c:\perl\lib/pods/perlapio.pod type=file
+c:\perl\lib/pods/perlapollo.pod type=file
+c:\perl\lib/pods/perlartistic.pod type=file
+c:\perl\lib/pods/perlbeos.pod type=file
+c:\perl\lib/pods/perlbook.pod type=file
+c:\perl\lib/pods/perlboot.pod type=file
+c:\perl\lib/pods/perlbot.pod type=file
+c:\perl\lib/pods/perlbs2000.pod type=file
+c:\perl\lib/pods/perlcall.pod type=file
+c:\perl\lib/pods/perlce.pod type=file
+c:\perl\lib/pods/perlcheat.pod type=file
+c:\perl\lib/pods/perlclib.pod type=file
+c:\perl\lib/pods/perlcn.pod type=file
+c:\perl\lib/pods/perlcommunity.pod type=file
+c:\perl\lib/pods/perlcompile.pod type=file
+c:\perl\lib/pods/perlcygwin.pod type=file
+c:\perl\lib/pods/perldata.pod type=file
+c:\perl\lib/pods/perldbmfilter.pod type=file
+c:\perl\lib/pods/perldebguts.pod type=file
+c:\perl\lib/pods/perldebtut.pod type=file
+c:\perl\lib/pods/perldebug.pod type=file
+c:\perl\lib/pods/perldelta.pod type=file
+c:\perl\lib/pods/perldgux.pod type=file
+c:\perl\lib/pods/perldiag.pod type=file
+c:\perl\lib/pods/perldoc.pod type=file
+c:\perl\lib/pods/perldos.pod type=file
+c:\perl\lib/pods/perldsc.pod type=file
+c:\perl\lib/pods/perlebcdic.pod type=file
+c:\perl\lib/pods/perlembed.pod type=file
+c:\perl\lib/pods/perlepoc.pod type=file
+c:\perl\lib/pods/perlfaq.pod type=file
+c:\perl\lib/pods/perlfaq1.pod type=file
+c:\perl\lib/pods/perlfaq2.pod type=file
+c:\perl\lib/pods/perlfaq3.pod type=file
+c:\perl\lib/pods/perlfaq4.pod type=file
+c:\perl\lib/pods/perlfaq5.pod type=file
+c:\perl\lib/pods/perlfaq6.pod type=file
+c:\perl\lib/pods/perlfaq7.pod type=file
+c:\perl\lib/pods/perlfaq8.pod type=file
+c:\perl\lib/pods/perlfaq9.pod type=file
+c:\perl\lib/pods/perlfilter.pod type=file
+c:\perl\lib/pods/perlfork.pod type=file
+c:\perl\lib/pods/perlform.pod type=file
+c:\perl\lib/pods/perlfreebsd.pod type=file
+c:\perl\lib/pods/perlfunc.pod type=file
+c:\perl\lib/pods/perlglossary.pod type=file
+c:\perl\lib/pods/perlgpl.pod type=file
+c:\perl\lib/pods/perlguts.pod type=file
+c:\perl\lib/pods/perlhack.pod type=file
+c:\perl\lib/pods/perlhaiku.pod type=file
+c:\perl\lib/pods/perlhist.pod type=file
+c:\perl\lib/pods/perlhpux.pod type=file
+c:\perl\lib/pods/perlhurd.pod type=file
+c:\perl\lib/pods/perlintern.pod type=file
+c:\perl\lib/pods/perlintro.pod type=file
+c:\perl\lib/pods/perliol.pod type=file
+c:\perl\lib/pods/perlipc.pod type=file
+c:\perl\lib/pods/perlirix.pod type=file
+c:\perl\lib/pods/perljp.pod type=file
+c:\perl\lib/pods/perlko.pod type=file
+c:\perl\lib/pods/perllexwarn.pod type=file
+c:\perl\lib/pods/perllinux.pod type=file
+c:\perl\lib/pods/perllocale.pod type=file
+c:\perl\lib/pods/perllol.pod type=file
+c:\perl\lib/pods/perlmacos.pod type=file
+c:\perl\lib/pods/perlmacosx.pod type=file
+c:\perl\lib/pods/perlmod.pod type=file
+c:\perl\lib/pods/perlmodinstall.pod type=file
+c:\perl\lib/pods/perlmodlib.pod type=file
+c:\perl\lib/pods/perlmodstyle.pod type=file
+c:\perl\lib/pods/perlmpeix.pod type=file
+c:\perl\lib/pods/perlmroapi.pod type=file
+c:\perl\lib/pods/perlnetware.pod type=file
+c:\perl\lib/pods/perlnewmod.pod type=file
+c:\perl\lib/pods/perlnumber.pod type=file
+c:\perl\lib/pods/perlobj.pod type=file
+c:\perl\lib/pods/perlop.pod type=file
+c:\perl\lib/pods/perlopenbsd.pod type=file
+c:\perl\lib/pods/perlopentut.pod type=file
+c:\perl\lib/pods/perlos2.pod type=file
+c:\perl\lib/pods/perlos390.pod type=file
+c:\perl\lib/pods/perlos400.pod type=file
+c:\perl\lib/pods/perlpacktut.pod type=file
+c:\perl\lib/pods/perlperf.pod type=file
+c:\perl\lib/pods/perlplan9.pod type=file
+c:\perl\lib/pods/perlpod.pod type=file
+c:\perl\lib/pods/perlpodspec.pod type=file
+c:\perl\lib/pods/perlpolicy.pod type=file
+c:\perl\lib/pods/perlport.pod type=file
+c:\perl\lib/pods/perlpragma.pod type=file
+c:\perl\lib/pods/perlqnx.pod type=file
+c:\perl\lib/pods/perlre.pod type=file
+c:\perl\lib/pods/perlreapi.pod type=file
+c:\perl\lib/pods/perlrebackslash.pod type=file
+c:\perl\lib/pods/perlrecharclass.pod type=file
+c:\perl\lib/pods/perlref.pod type=file
+c:\perl\lib/pods/perlreftut.pod type=file
+c:\perl\lib/pods/perlreguts.pod type=file
+c:\perl\lib/pods/perlrepository.pod type=file
+c:\perl\lib/pods/perlrequick.pod type=file
+c:\perl\lib/pods/perlreref.pod type=file
+c:\perl\lib/pods/perlretut.pod type=file
+c:\perl\lib/pods/perlriscos.pod type=file
+c:\perl\lib/pods/perlrun.pod type=file
+c:\perl\lib/pods/perlsec.pod type=file
+c:\perl\lib/pods/perlsolaris.pod type=file
+c:\perl\lib/pods/perlstyle.pod type=file
+c:\perl\lib/pods/perlsub.pod type=file
+c:\perl\lib/pods/perlsymbian.pod type=file
+c:\perl\lib/pods/perlsyn.pod type=file
+c:\perl\lib/pods/perlthrtut.pod type=file
+c:\perl\lib/pods/perltie.pod type=file
+c:\perl\lib/pods/perltoc.pod type=file
+c:\perl\lib/pods/perltodo.pod type=file
+c:\perl\lib/pods/perltooc.pod type=file
+c:\perl\lib/pods/perltoot.pod type=file
+c:\perl\lib/pods/perltrap.pod type=file
+c:\perl\lib/pods/perltru64.pod type=file
+c:\perl\lib/pods/perltw.pod type=file
+c:\perl\lib/pods/perlunicode.pod type=file
+c:\perl\lib/pods/perlunifaq.pod type=file
+c:\perl\lib/pods/perluniintro.pod type=file
+c:\perl\lib/pods/perluniprops.pod type=file
+c:\perl\lib/pods/perlunitut.pod type=file
+c:\perl\lib/pods/perlutil.pod type=file
+c:\perl\lib/pods/perluts.pod type=file
+c:\perl\lib/pods/perlvar.pod type=file
+c:\perl\lib/pods/perlvmesa.pod type=file
+c:\perl\lib/pods/perlvms.pod type=file
+c:\perl\lib/pods/perlvos.pod type=file
+c:\perl\lib/pods/perlwin32.pod type=file
+c:\perl\lib/pods/perlxs.pod type=file
+c:\perl\lib/pods/perlxstut.pod type=file
+c:\perl\lib/pwd.pl type=file
+c:\perl\lib/re.pm type=file
+c:\perl\lib/shellwords.pl type=file
+c:\perl\lib/sigtrap.pm type=file
+c:\perl\lib/sort.pm type=file
+c:\perl\lib/stat.pl type=file
+c:\perl\lib/strict.pm type=file
+c:\perl\lib/subs.pm type=file
+c:\perl\lib/syslog.pl type=file
+c:\perl\lib/tainted.pl type=file
+c:\perl\lib/termcap.pl type=file
+c:\perl\lib/threads.pm type=file
+c:\perl\lib/threads/shared.pm type=file
+c:\perl\lib/timelocal.pl type=file
+c:\perl\lib/unicore/ArabicShaping.txt type=file
+c:\perl\lib/unicore/BidiMirroring.txt type=file
+c:\perl\lib/unicore/Blocks.txt type=file
+c:\perl\lib/unicore/CJKRadicals.txt type=file
+c:\perl\lib/unicore/CaseFolding.txt type=file
+c:\perl\lib/unicore/CombiningClass.pl type=file
+c:\perl\lib/unicore/CompositionExclusions.txt type=file
+c:\perl\lib/unicore/DAge.txt type=file
+c:\perl\lib/unicore/DCoreProperties.txt type=file
+c:\perl\lib/unicore/DNormalizationProps.txt type=file
+c:\perl\lib/unicore/Decomposition.pl type=file
+c:\perl\lib/unicore/EastAsianWidth.txt type=file
+c:\perl\lib/unicore/HangulSyllableType.txt type=file
+c:\perl\lib/unicore/Heavy.pl type=file
+c:\perl\lib/unicore/Index.txt type=file
+c:\perl\lib/unicore/Jamo.txt type=file
+c:\perl\lib/unicore/LineBreak.txt type=file
+c:\perl\lib/unicore/Name.pl type=file
+c:\perl\lib/unicore/NameAliases.txt type=file
+c:\perl\lib/unicore/NamedSequences.txt type=file
+c:\perl\lib/unicore/NamedSqProv.txt type=file
+c:\perl\lib/unicore/NamesList.txt type=file
+c:\perl\lib/unicore/NormalizationCorrections.txt type=file
+c:\perl\lib/unicore/PropList.txt type=file
+c:\perl\lib/unicore/PropValueAliases.txt type=file
+c:\perl\lib/unicore/PropertyAliases.txt type=file
+c:\perl\lib/unicore/ReadMe.txt type=file
+c:\perl\lib/unicore/Scripts.txt type=file
+c:\perl\lib/unicore/SpecialCasing.txt type=file
+c:\perl\lib/unicore/StandardizedVariants.txt type=file
+c:\perl\lib/unicore/TestProp.pl type=file
+c:\perl\lib/unicore/To/Bmg.pl type=file
+c:\perl\lib/unicore/To/Digit.pl type=file
+c:\perl\lib/unicore/To/Fold.pl type=file
+c:\perl\lib/unicore/To/Lower.pl type=file
+c:\perl\lib/unicore/To/NFKCCF.pl type=file
+c:\perl\lib/unicore/To/Title.pl type=file
+c:\perl\lib/unicore/To/Upper.pl type=file
+c:\perl\lib/unicore/UnicodeData.txt type=file
+c:\perl\lib/unicore/auxiliary/GCBTest.txt type=file
+c:\perl\lib/unicore/auxiliary/GraphemeBreakProperty.txt type=file
+c:\perl\lib/unicore/auxiliary/SentenceBreakProperty.txt type=file
+c:\perl\lib/unicore/auxiliary/WordBreakProperty.txt type=file
+c:\perl\lib/unicore/extracted/DBidiClass.txt type=file
+c:\perl\lib/unicore/extracted/DBinaryProperties.txt type=file
+c:\perl\lib/unicore/extracted/DCombiningClass.txt type=file
+c:\perl\lib/unicore/extracted/DDecompositionType.txt type=file
+c:\perl\lib/unicore/extracted/DEastAsianWidth.txt type=file
+c:\perl\lib/unicore/extracted/DGeneralCategory.txt type=file
+c:\perl\lib/unicore/extracted/DJoinGroup.txt type=file
+c:\perl\lib/unicore/extracted/DJoinType.txt type=file
+c:\perl\lib/unicore/extracted/DLineBreak.txt type=file
+c:\perl\lib/unicore/extracted/DNumType.txt type=file
+c:\perl\lib/unicore/extracted/DNumValues.txt type=file
+c:\perl\lib/unicore/lib/AHex/N.pl type=file
+c:\perl\lib/unicore/lib/AHex/Y.pl type=file
+c:\perl\lib/unicore/lib/Age/1_1.pl type=file
+c:\perl\lib/unicore/lib/Age/2_0.pl type=file
+c:\perl\lib/unicore/lib/Age/2_1.pl type=file
+c:\perl\lib/unicore/lib/Age/3_0.pl type=file
+c:\perl\lib/unicore/lib/Age/3_1.pl type=file
+c:\perl\lib/unicore/lib/Age/3_2.pl type=file
+c:\perl\lib/unicore/lib/Age/4_0.pl type=file
+c:\perl\lib/unicore/lib/Age/4_1.pl type=file
+c:\perl\lib/unicore/lib/Age/5_0.pl type=file
+c:\perl\lib/unicore/lib/Age/5_1.pl type=file
+c:\perl\lib/unicore/lib/Age/5_2.pl type=file
+c:\perl\lib/unicore/lib/Age/Unassign.pl type=file
+c:\perl\lib/unicore/lib/Alpha/N.pl type=file
+c:\perl\lib/unicore/lib/Alpha/Y.pl type=file
+c:\perl\lib/unicore/lib/Bc/AL.pl type=file
+c:\perl\lib/unicore/lib/Bc/AN.pl type=file
+c:\perl\lib/unicore/lib/Bc/B.pl type=file
+c:\perl\lib/unicore/lib/Bc/BN.pl type=file
+c:\perl\lib/unicore/lib/Bc/CS.pl type=file
+c:\perl\lib/unicore/lib/Bc/EN.pl type=file
+c:\perl\lib/unicore/lib/Bc/ES.pl type=file
+c:\perl\lib/unicore/lib/Bc/ET.pl type=file
+c:\perl\lib/unicore/lib/Bc/L.pl type=file
+c:\perl\lib/unicore/lib/Bc/LRE.pl type=file
+c:\perl\lib/unicore/lib/Bc/LRO.pl type=file
+c:\perl\lib/unicore/lib/Bc/NSM.pl type=file
+c:\perl\lib/unicore/lib/Bc/ON.pl type=file
+c:\perl\lib/unicore/lib/Bc/PDF.pl type=file
+c:\perl\lib/unicore/lib/Bc/R.pl type=file
+c:\perl\lib/unicore/lib/Bc/RLE.pl type=file
+c:\perl\lib/unicore/lib/Bc/RLO.pl type=file
+c:\perl\lib/unicore/lib/Bc/S.pl type=file
+c:\perl\lib/unicore/lib/Bc/WS.pl type=file
+c:\perl\lib/unicore/lib/BidiC/N.pl type=file
+c:\perl\lib/unicore/lib/BidiC/Y.pl type=file
+c:\perl\lib/unicore/lib/BidiM/N.pl type=file
+c:\perl\lib/unicore/lib/BidiM/Y.pl type=file
+c:\perl\lib/unicore/lib/Blk/ASCII.pl type=file
+c:\perl\lib/unicore/lib/Blk/AegeanNu.pl type=file
+c:\perl\lib/unicore/lib/Blk/Alphabet.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ancient2.pl type=file
+c:\perl\lib/unicore/lib/Blk/AncientG.pl type=file
+c:\perl\lib/unicore/lib/Blk/AncientS.pl type=file
+c:\perl\lib/unicore/lib/Blk/Arabic.pl type=file
+c:\perl\lib/unicore/lib/Blk/ArabicP2.pl type=file
+c:\perl\lib/unicore/lib/Blk/ArabicPr.pl type=file
+c:\perl\lib/unicore/lib/Blk/ArabicSu.pl type=file
+c:\perl\lib/unicore/lib/Blk/Armenian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Arrows.pl type=file
+c:\perl\lib/unicore/lib/Blk/Avestan.pl type=file
+c:\perl\lib/unicore/lib/Blk/Balinese.pl type=file
+c:\perl\lib/unicore/lib/Blk/Bamum.pl type=file
+c:\perl\lib/unicore/lib/Blk/Bengali.pl type=file
+c:\perl\lib/unicore/lib/Blk/BlockEle.pl type=file
+c:\perl\lib/unicore/lib/Blk/Bopomof2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Bopomofo.pl type=file
+c:\perl\lib/unicore/lib/Blk/BoxDrawi.pl type=file
+c:\perl\lib/unicore/lib/Blk/BrailleP.pl type=file
+c:\perl\lib/unicore/lib/Blk/Buginese.pl type=file
+c:\perl\lib/unicore/lib/Blk/Buhid.pl type=file
+c:\perl\lib/unicore/lib/Blk/Byzantin.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKComp2.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKComp3.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKComp4.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKCompa.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKRadic.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKStrok.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKSymbo.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKUnif2.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKUnif3.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKUnif4.pl type=file
+c:\perl\lib/unicore/lib/Blk/CJKUnifi.pl type=file
+c:\perl\lib/unicore/lib/Blk/Canadian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Carian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cham.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cherokee.pl type=file
+c:\perl\lib/unicore/lib/Blk/Combini2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Combini3.pl type=file
+c:\perl\lib/unicore/lib/Blk/Combini4.pl type=file
+c:\perl\lib/unicore/lib/Blk/Combinin.pl type=file
+c:\perl\lib/unicore/lib/Blk/CommonIn.pl type=file
+c:\perl\lib/unicore/lib/Blk/ControlP.pl type=file
+c:\perl\lib/unicore/lib/Blk/Coptic.pl type=file
+c:\perl\lib/unicore/lib/Blk/Counting.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cuneifo2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cuneifor.pl type=file
+c:\perl\lib/unicore/lib/Blk/Currency.pl type=file
+c:\perl\lib/unicore/lib/Blk/CypriotS.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cyrilli2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cyrilli3.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cyrilli4.pl type=file
+c:\perl\lib/unicore/lib/Blk/Cyrillic.pl type=file
+c:\perl\lib/unicore/lib/Blk/Deseret.pl type=file
+c:\perl\lib/unicore/lib/Blk/Devanag2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Devanaga.pl type=file
+c:\perl\lib/unicore/lib/Blk/Dingbats.pl type=file
+c:\perl\lib/unicore/lib/Blk/DominoTi.pl type=file
+c:\perl\lib/unicore/lib/Blk/Egyptian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Enclose2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Enclose3.pl type=file
+c:\perl\lib/unicore/lib/Blk/Enclose4.pl type=file
+c:\perl\lib/unicore/lib/Blk/Enclosed.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ethiopi2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ethiopi3.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ethiopic.pl type=file
+c:\perl\lib/unicore/lib/Blk/GeneralP.pl type=file
+c:\perl\lib/unicore/lib/Blk/Geometri.pl type=file
+c:\perl\lib/unicore/lib/Blk/Georgia2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Georgian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Glagolit.pl type=file
+c:\perl\lib/unicore/lib/Blk/Gothic.pl type=file
+c:\perl\lib/unicore/lib/Blk/Greek.pl type=file
+c:\perl\lib/unicore/lib/Blk/GreekExt.pl type=file
+c:\perl\lib/unicore/lib/Blk/Gujarati.pl type=file
+c:\perl\lib/unicore/lib/Blk/Gurmukhi.pl type=file
+c:\perl\lib/unicore/lib/Blk/Halfwidt.pl type=file
+c:\perl\lib/unicore/lib/Blk/HangulCo.pl type=file
+c:\perl\lib/unicore/lib/Blk/HangulJ2.pl type=file
+c:\perl\lib/unicore/lib/Blk/HangulJ3.pl type=file
+c:\perl\lib/unicore/lib/Blk/HangulJa.pl type=file
+c:\perl\lib/unicore/lib/Blk/HangulSy.pl type=file
+c:\perl\lib/unicore/lib/Blk/Hanunoo.pl type=file
+c:\perl\lib/unicore/lib/Blk/Hebrew.pl type=file
+c:\perl\lib/unicore/lib/Blk/HighPriv.pl type=file
+c:\perl\lib/unicore/lib/Blk/HighSurr.pl type=file
+c:\perl\lib/unicore/lib/Blk/Hiragana.pl type=file
+c:\perl\lib/unicore/lib/Blk/IPAExten.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ideograp.pl type=file
+c:\perl\lib/unicore/lib/Blk/Imperial.pl type=file
+c:\perl\lib/unicore/lib/Blk/Inscrip2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Inscript.pl type=file
+c:\perl\lib/unicore/lib/Blk/Javanese.pl type=file
+c:\perl\lib/unicore/lib/Blk/Kaithi.pl type=file
+c:\perl\lib/unicore/lib/Blk/Kanbun.pl type=file
+c:\perl\lib/unicore/lib/Blk/KangxiRa.pl type=file
+c:\perl\lib/unicore/lib/Blk/Kannada.pl type=file
+c:\perl\lib/unicore/lib/Blk/Katakan2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Katakana.pl type=file
+c:\perl\lib/unicore/lib/Blk/KayahLi.pl type=file
+c:\perl\lib/unicore/lib/Blk/Kharosht.pl type=file
+c:\perl\lib/unicore/lib/Blk/Khmer.pl type=file
+c:\perl\lib/unicore/lib/Blk/KhmerSym.pl type=file
+c:\perl\lib/unicore/lib/Blk/Lao.pl type=file
+c:\perl\lib/unicore/lib/Blk/Latin1.pl type=file
+c:\perl\lib/unicore/lib/Blk/LatinEx2.pl type=file
+c:\perl\lib/unicore/lib/Blk/LatinEx3.pl type=file
+c:\perl\lib/unicore/lib/Blk/LatinEx4.pl type=file
+c:\perl\lib/unicore/lib/Blk/LatinEx5.pl type=file
+c:\perl\lib/unicore/lib/Blk/LatinExt.pl type=file
+c:\perl\lib/unicore/lib/Blk/Lepcha.pl type=file
+c:\perl\lib/unicore/lib/Blk/Letterli.pl type=file
+c:\perl\lib/unicore/lib/Blk/Limbu.pl type=file
+c:\perl\lib/unicore/lib/Blk/LinearBI.pl type=file
+c:\perl\lib/unicore/lib/Blk/LinearBS.pl type=file
+c:\perl\lib/unicore/lib/Blk/Lisu.pl type=file
+c:\perl\lib/unicore/lib/Blk/LowSurro.pl type=file
+c:\perl\lib/unicore/lib/Blk/Lycian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Lydian.pl type=file
+c:\perl\lib/unicore/lib/Blk/MahjongT.pl type=file
+c:\perl\lib/unicore/lib/Blk/Malayala.pl type=file
+c:\perl\lib/unicore/lib/Blk/Mathema2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Mathemat.pl type=file
+c:\perl\lib/unicore/lib/Blk/MeeteiMa.pl type=file
+c:\perl\lib/unicore/lib/Blk/Miscell2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Miscell3.pl type=file
+c:\perl\lib/unicore/lib/Blk/Miscell4.pl type=file
+c:\perl\lib/unicore/lib/Blk/Miscell5.pl type=file
+c:\perl\lib/unicore/lib/Blk/Miscella.pl type=file
+c:\perl\lib/unicore/lib/Blk/Modifier.pl type=file
+c:\perl\lib/unicore/lib/Blk/Mongolia.pl type=file
+c:\perl\lib/unicore/lib/Blk/MusicalS.pl type=file
+c:\perl\lib/unicore/lib/Blk/Myanmar.pl type=file
+c:\perl\lib/unicore/lib/Blk/MyanmarE.pl type=file
+c:\perl\lib/unicore/lib/Blk/NKo.pl type=file
+c:\perl\lib/unicore/lib/Blk/NewTaiLu.pl type=file
+c:\perl\lib/unicore/lib/Blk/NoBlock.pl type=file
+c:\perl\lib/unicore/lib/Blk/NumberFo.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ogham.pl type=file
+c:\perl\lib/unicore/lib/Blk/OlChiki.pl type=file
+c:\perl\lib/unicore/lib/Blk/OldItali.pl type=file
+c:\perl\lib/unicore/lib/Blk/OldPersi.pl type=file
+c:\perl\lib/unicore/lib/Blk/OldSouth.pl type=file
+c:\perl\lib/unicore/lib/Blk/OldTurki.pl type=file
+c:\perl\lib/unicore/lib/Blk/OpticalC.pl type=file
+c:\perl\lib/unicore/lib/Blk/Oriya.pl type=file
+c:\perl\lib/unicore/lib/Blk/Osmanya.pl type=file
+c:\perl\lib/unicore/lib/Blk/PhagsPa.pl type=file
+c:\perl\lib/unicore/lib/Blk/Phaistos.pl type=file
+c:\perl\lib/unicore/lib/Blk/Phoenici.pl type=file
+c:\perl\lib/unicore/lib/Blk/Phoneti2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Phonetic.pl type=file
+c:\perl\lib/unicore/lib/Blk/PrivateU.pl type=file
+c:\perl\lib/unicore/lib/Blk/Rejang.pl type=file
+c:\perl\lib/unicore/lib/Blk/RumiNume.pl type=file
+c:\perl\lib/unicore/lib/Blk/Runic.pl type=file
+c:\perl\lib/unicore/lib/Blk/Samarita.pl type=file
+c:\perl\lib/unicore/lib/Blk/Saurasht.pl type=file
+c:\perl\lib/unicore/lib/Blk/Shavian.pl type=file
+c:\perl\lib/unicore/lib/Blk/Sinhala.pl type=file
+c:\perl\lib/unicore/lib/Blk/SmallFor.pl type=file
+c:\perl\lib/unicore/lib/Blk/SpacingM.pl type=file
+c:\perl\lib/unicore/lib/Blk/Specials.pl type=file
+c:\perl\lib/unicore/lib/Blk/Sundanes.pl type=file
+c:\perl\lib/unicore/lib/Blk/Superscr.pl type=file
+c:\perl\lib/unicore/lib/Blk/Supplem2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Supplem3.pl type=file
+c:\perl\lib/unicore/lib/Blk/Supplem4.pl type=file
+c:\perl\lib/unicore/lib/Blk/Supplem5.pl type=file
+c:\perl\lib/unicore/lib/Blk/Supplem6.pl type=file
+c:\perl\lib/unicore/lib/Blk/Suppleme.pl type=file
+c:\perl\lib/unicore/lib/Blk/SylotiNa.pl type=file
+c:\perl\lib/unicore/lib/Blk/Syriac.pl type=file
+c:\perl\lib/unicore/lib/Blk/Tagalog.pl type=file
+c:\perl\lib/unicore/lib/Blk/Tagbanwa.pl type=file
+c:\perl\lib/unicore/lib/Blk/Tags.pl type=file
+c:\perl\lib/unicore/lib/Blk/TaiLe.pl type=file
+c:\perl\lib/unicore/lib/Blk/TaiTham.pl type=file
+c:\perl\lib/unicore/lib/Blk/TaiViet.pl type=file
+c:\perl\lib/unicore/lib/Blk/TaiXuanJ.pl type=file
+c:\perl\lib/unicore/lib/Blk/Tamil.pl type=file
+c:\perl\lib/unicore/lib/Blk/Telugu.pl type=file
+c:\perl\lib/unicore/lib/Blk/Thaana.pl type=file
+c:\perl\lib/unicore/lib/Blk/Thai.pl type=file
+c:\perl\lib/unicore/lib/Blk/Tibetan.pl type=file
+c:\perl\lib/unicore/lib/Blk/Tifinagh.pl type=file
+c:\perl\lib/unicore/lib/Blk/Ugaritic.pl type=file
+c:\perl\lib/unicore/lib/Blk/UnifiedC.pl type=file
+c:\perl\lib/unicore/lib/Blk/Vai.pl type=file
+c:\perl\lib/unicore/lib/Blk/Variati2.pl type=file
+c:\perl\lib/unicore/lib/Blk/Variatio.pl type=file
+c:\perl\lib/unicore/lib/Blk/VedicExt.pl type=file
+c:\perl\lib/unicore/lib/Blk/Vertical.pl type=file
+c:\perl\lib/unicore/lib/Blk/YiRadica.pl type=file
+c:\perl\lib/unicore/lib/Blk/YiSyllab.pl type=file
+c:\perl\lib/unicore/lib/Blk/YijingHe.pl type=file
+c:\perl\lib/unicore/lib/CE/N.pl type=file
+c:\perl\lib/unicore/lib/CE/Y.pl type=file
+c:\perl\lib/unicore/lib/CI/N.pl type=file
+c:\perl\lib/unicore/lib/CI/Y.pl type=file
+c:\perl\lib/unicore/lib/CWCF/N.pl type=file
+c:\perl\lib/unicore/lib/CWCF/Y.pl type=file
+c:\perl\lib/unicore/lib/CWCM/N.pl type=file
+c:\perl\lib/unicore/lib/CWCM/Y.pl type=file
+c:\perl\lib/unicore/lib/CWKCF/N.pl type=file
+c:\perl\lib/unicore/lib/CWKCF/Y.pl type=file
+c:\perl\lib/unicore/lib/CWL/N.pl type=file
+c:\perl\lib/unicore/lib/CWL/Y.pl type=file
+c:\perl\lib/unicore/lib/CWT/N.pl type=file
+c:\perl\lib/unicore/lib/CWT/Y.pl type=file
+c:\perl\lib/unicore/lib/CWU/N.pl type=file
+c:\perl\lib/unicore/lib/CWU/Y.pl type=file
+c:\perl\lib/unicore/lib/Cased/N.pl type=file
+c:\perl\lib/unicore/lib/Cased/Y.pl type=file
+c:\perl\lib/unicore/lib/Ccc/10.pl type=file
+c:\perl\lib/unicore/lib/Ccc/103.pl type=file
+c:\perl\lib/unicore/lib/Ccc/107.pl type=file
+c:\perl\lib/unicore/lib/Ccc/11.pl type=file
+c:\perl\lib/unicore/lib/Ccc/118.pl type=file
+c:\perl\lib/unicore/lib/Ccc/12.pl type=file
+c:\perl\lib/unicore/lib/Ccc/122.pl type=file
+c:\perl\lib/unicore/lib/Ccc/129.pl type=file
+c:\perl\lib/unicore/lib/Ccc/13.pl type=file
+c:\perl\lib/unicore/lib/Ccc/130.pl type=file
+c:\perl\lib/unicore/lib/Ccc/132.pl type=file
+c:\perl\lib/unicore/lib/Ccc/14.pl type=file
+c:\perl\lib/unicore/lib/Ccc/15.pl type=file
+c:\perl\lib/unicore/lib/Ccc/16.pl type=file
+c:\perl\lib/unicore/lib/Ccc/17.pl type=file
+c:\perl\lib/unicore/lib/Ccc/18.pl type=file
+c:\perl\lib/unicore/lib/Ccc/19.pl type=file
+c:\perl\lib/unicore/lib/Ccc/20.pl type=file
+c:\perl\lib/unicore/lib/Ccc/21.pl type=file
+c:\perl\lib/unicore/lib/Ccc/22.pl type=file
+c:\perl\lib/unicore/lib/Ccc/23.pl type=file
+c:\perl\lib/unicore/lib/Ccc/24.pl type=file
+c:\perl\lib/unicore/lib/Ccc/25.pl type=file
+c:\perl\lib/unicore/lib/Ccc/26.pl type=file
+c:\perl\lib/unicore/lib/Ccc/27.pl type=file
+c:\perl\lib/unicore/lib/Ccc/28.pl type=file
+c:\perl\lib/unicore/lib/Ccc/29.pl type=file
+c:\perl\lib/unicore/lib/Ccc/30.pl type=file
+c:\perl\lib/unicore/lib/Ccc/31.pl type=file
+c:\perl\lib/unicore/lib/Ccc/32.pl type=file
+c:\perl\lib/unicore/lib/Ccc/33.pl type=file
+c:\perl\lib/unicore/lib/Ccc/34.pl type=file
+c:\perl\lib/unicore/lib/Ccc/35.pl type=file
+c:\perl\lib/unicore/lib/Ccc/36.pl type=file
+c:\perl\lib/unicore/lib/Ccc/84.pl type=file
+c:\perl\lib/unicore/lib/Ccc/91.pl type=file
+c:\perl\lib/unicore/lib/Ccc/A.pl type=file
+c:\perl\lib/unicore/lib/Ccc/AL.pl type=file
+c:\perl\lib/unicore/lib/Ccc/AR.pl type=file
+c:\perl\lib/unicore/lib/Ccc/ATA.pl type=file
+c:\perl\lib/unicore/lib/Ccc/ATAR.pl type=file
+c:\perl\lib/unicore/lib/Ccc/ATB.pl type=file
+c:\perl\lib/unicore/lib/Ccc/ATBL.pl type=file
+c:\perl\lib/unicore/lib/Ccc/B.pl type=file
+c:\perl\lib/unicore/lib/Ccc/BL.pl type=file
+c:\perl\lib/unicore/lib/Ccc/BR.pl type=file
+c:\perl\lib/unicore/lib/Ccc/DA.pl type=file
+c:\perl\lib/unicore/lib/Ccc/DB.pl type=file
+c:\perl\lib/unicore/lib/Ccc/IS.pl type=file
+c:\perl\lib/unicore/lib/Ccc/KV.pl type=file
+c:\perl\lib/unicore/lib/Ccc/L.pl type=file
+c:\perl\lib/unicore/lib/Ccc/NK.pl type=file
+c:\perl\lib/unicore/lib/Ccc/NR.pl type=file
+c:\perl\lib/unicore/lib/Ccc/OV.pl type=file
+c:\perl\lib/unicore/lib/Ccc/R.pl type=file
+c:\perl\lib/unicore/lib/Ccc/VR.pl type=file
+c:\perl\lib/unicore/lib/CompEx/N.pl type=file
+c:\perl\lib/unicore/lib/CompEx/Y.pl type=file
+c:\perl\lib/unicore/lib/DI/N.pl type=file
+c:\perl\lib/unicore/lib/DI/Y.pl type=file
+c:\perl\lib/unicore/lib/Dash/N.pl type=file
+c:\perl\lib/unicore/lib/Dash/Y.pl type=file
+c:\perl\lib/unicore/lib/Dep/N.pl type=file
+c:\perl\lib/unicore/lib/Dep/Y.pl type=file
+c:\perl\lib/unicore/lib/Dia/N.pl type=file
+c:\perl\lib/unicore/lib/Dia/Y.pl type=file
+c:\perl\lib/unicore/lib/Dt/Com.pl type=file
+c:\perl\lib/unicore/lib/Dt/Enc.pl type=file
+c:\perl\lib/unicore/lib/Dt/Fin.pl type=file
+c:\perl\lib/unicore/lib/Dt/Font.pl type=file
+c:\perl\lib/unicore/lib/Dt/Fra.pl type=file
+c:\perl\lib/unicore/lib/Dt/Init.pl type=file
+c:\perl\lib/unicore/lib/Dt/Iso.pl type=file
+c:\perl\lib/unicore/lib/Dt/Med.pl type=file
+c:\perl\lib/unicore/lib/Dt/Nar.pl type=file
+c:\perl\lib/unicore/lib/Dt/Nb.pl type=file
+c:\perl\lib/unicore/lib/Dt/NonCanon.pl type=file
+c:\perl\lib/unicore/lib/Dt/None.pl type=file
+c:\perl\lib/unicore/lib/Dt/Sml.pl type=file
+c:\perl\lib/unicore/lib/Dt/Sqr.pl type=file
+c:\perl\lib/unicore/lib/Dt/Sub.pl type=file
+c:\perl\lib/unicore/lib/Dt/Sup.pl type=file
+c:\perl\lib/unicore/lib/Dt/Vert.pl type=file
+c:\perl\lib/unicore/lib/Ea/A.pl type=file
+c:\perl\lib/unicore/lib/Ea/F.pl type=file
+c:\perl\lib/unicore/lib/Ea/H.pl type=file
+c:\perl\lib/unicore/lib/Ea/N.pl type=file
+c:\perl\lib/unicore/lib/Ea/Na.pl type=file
+c:\perl\lib/unicore/lib/Ea/W.pl type=file
+c:\perl\lib/unicore/lib/Ext/N.pl type=file
+c:\perl\lib/unicore/lib/Ext/Y.pl type=file
+c:\perl\lib/unicore/lib/GCB/CN.pl type=file
+c:\perl\lib/unicore/lib/GCB/CR.pl type=file
+c:\perl\lib/unicore/lib/GCB/EX.pl type=file
+c:\perl\lib/unicore/lib/GCB/L.pl type=file
+c:\perl\lib/unicore/lib/GCB/LF.pl type=file
+c:\perl\lib/unicore/lib/GCB/LV.pl type=file
+c:\perl\lib/unicore/lib/GCB/LVT.pl type=file
+c:\perl\lib/unicore/lib/GCB/PP.pl type=file
+c:\perl\lib/unicore/lib/GCB/SM.pl type=file
+c:\perl\lib/unicore/lib/GCB/T.pl type=file
+c:\perl\lib/unicore/lib/GCB/V.pl type=file
+c:\perl\lib/unicore/lib/GCB/XX.pl type=file
+c:\perl\lib/unicore/lib/Gc/C.pl type=file
+c:\perl\lib/unicore/lib/Gc/Cc.pl type=file
+c:\perl\lib/unicore/lib/Gc/Cf.pl type=file
+c:\perl\lib/unicore/lib/Gc/Cn.pl type=file
+c:\perl\lib/unicore/lib/Gc/Co.pl type=file
+c:\perl\lib/unicore/lib/Gc/Cs.pl type=file
+c:\perl\lib/unicore/lib/Gc/L.pl type=file
+c:\perl\lib/unicore/lib/Gc/LC.pl type=file
+c:\perl\lib/unicore/lib/Gc/Ll.pl type=file
+c:\perl\lib/unicore/lib/Gc/Lm.pl type=file
+c:\perl\lib/unicore/lib/Gc/Lo.pl type=file
+c:\perl\lib/unicore/lib/Gc/Lt.pl type=file
+c:\perl\lib/unicore/lib/Gc/Lu.pl type=file
+c:\perl\lib/unicore/lib/Gc/M.pl type=file
+c:\perl\lib/unicore/lib/Gc/Mc.pl type=file
+c:\perl\lib/unicore/lib/Gc/Me.pl type=file
+c:\perl\lib/unicore/lib/Gc/Mn.pl type=file
+c:\perl\lib/unicore/lib/Gc/N.pl type=file
+c:\perl\lib/unicore/lib/Gc/Nl.pl type=file
+c:\perl\lib/unicore/lib/Gc/No.pl type=file
+c:\perl\lib/unicore/lib/Gc/P.pl type=file
+c:\perl\lib/unicore/lib/Gc/Pd.pl type=file
+c:\perl\lib/unicore/lib/Gc/Pe.pl type=file
+c:\perl\lib/unicore/lib/Gc/Pf.pl type=file
+c:\perl\lib/unicore/lib/Gc/Pi.pl type=file
+c:\perl\lib/unicore/lib/Gc/Po.pl type=file
+c:\perl\lib/unicore/lib/Gc/Ps.pl type=file
+c:\perl\lib/unicore/lib/Gc/S.pl type=file
+c:\perl\lib/unicore/lib/Gc/Sc.pl type=file
+c:\perl\lib/unicore/lib/Gc/Sk.pl type=file
+c:\perl\lib/unicore/lib/Gc/Sm.pl type=file
+c:\perl\lib/unicore/lib/Gc/So.pl type=file
+c:\perl\lib/unicore/lib/Gc/Z.pl type=file
+c:\perl\lib/unicore/lib/Gc/Zl.pl type=file
+c:\perl\lib/unicore/lib/Gc/Zp.pl type=file
+c:\perl\lib/unicore/lib/Gc/Zs.pl type=file
+c:\perl\lib/unicore/lib/GrBase/N.pl type=file
+c:\perl\lib/unicore/lib/GrBase/Y.pl type=file
+c:\perl\lib/unicore/lib/GrExt/N.pl type=file
+c:\perl\lib/unicore/lib/GrExt/Y.pl type=file
+c:\perl\lib/unicore/lib/Hex/N.pl type=file
+c:\perl\lib/unicore/lib/Hex/Y.pl type=file
+c:\perl\lib/unicore/lib/Hst/NA.pl type=file
+c:\perl\lib/unicore/lib/Hyphen/N.pl type=file
+c:\perl\lib/unicore/lib/Hyphen/Y.pl type=file
+c:\perl\lib/unicore/lib/IDC/N.pl type=file
+c:\perl\lib/unicore/lib/IDC/Y.pl type=file
+c:\perl\lib/unicore/lib/IDS/N.pl type=file
+c:\perl\lib/unicore/lib/IDS/Y.pl type=file
+c:\perl\lib/unicore/lib/IDSB/N.pl type=file
+c:\perl\lib/unicore/lib/IDSB/Y.pl type=file
+c:\perl\lib/unicore/lib/IDST/N.pl type=file
+c:\perl\lib/unicore/lib/IDST/Y.pl type=file
+c:\perl\lib/unicore/lib/Ideo/N.pl type=file
+c:\perl\lib/unicore/lib/Ideo/Y.pl type=file
+c:\perl\lib/unicore/lib/In/2_0.pl type=file
+c:\perl\lib/unicore/lib/In/2_1.pl type=file
+c:\perl\lib/unicore/lib/In/3_0.pl type=file
+c:\perl\lib/unicore/lib/In/3_1.pl type=file
+c:\perl\lib/unicore/lib/In/3_2.pl type=file
+c:\perl\lib/unicore/lib/In/4_0.pl type=file
+c:\perl\lib/unicore/lib/In/4_1.pl type=file
+c:\perl\lib/unicore/lib/In/5_0.pl type=file
+c:\perl\lib/unicore/lib/In/5_1.pl type=file
+c:\perl\lib/unicore/lib/In/5_2.pl type=file
+c:\perl\lib/unicore/lib/Jg/Ain.pl type=file
+c:\perl\lib/unicore/lib/Jg/Alaph.pl type=file
+c:\perl\lib/unicore/lib/Jg/Alef.pl type=file
+c:\perl\lib/unicore/lib/Jg/Beh.pl type=file
+c:\perl\lib/unicore/lib/Jg/Beth.pl type=file
+c:\perl\lib/unicore/lib/Jg/Burushas.pl type=file
+c:\perl\lib/unicore/lib/Jg/Dal.pl type=file
+c:\perl\lib/unicore/lib/Jg/DalathRi.pl type=file
+c:\perl\lib/unicore/lib/Jg/E.pl type=file
+c:\perl\lib/unicore/lib/Jg/FarsiYeh.pl type=file
+c:\perl\lib/unicore/lib/Jg/Fe.pl type=file
+c:\perl\lib/unicore/lib/Jg/Feh.pl type=file
+c:\perl\lib/unicore/lib/Jg/FinalSem.pl type=file
+c:\perl\lib/unicore/lib/Jg/Gaf.pl type=file
+c:\perl\lib/unicore/lib/Jg/Gamal.pl type=file
+c:\perl\lib/unicore/lib/Jg/Hah.pl type=file
+c:\perl\lib/unicore/lib/Jg/HamzaOnH.pl type=file
+c:\perl\lib/unicore/lib/Jg/He.pl type=file
+c:\perl\lib/unicore/lib/Jg/Heh.pl type=file
+c:\perl\lib/unicore/lib/Jg/HehGoal.pl type=file
+c:\perl\lib/unicore/lib/Jg/Heth.pl type=file
+c:\perl\lib/unicore/lib/Jg/Kaf.pl type=file
+c:\perl\lib/unicore/lib/Jg/Kaph.pl type=file
+c:\perl\lib/unicore/lib/Jg/Khaph.pl type=file
+c:\perl\lib/unicore/lib/Jg/KnottedH.pl type=file
+c:\perl\lib/unicore/lib/Jg/Lam.pl type=file
+c:\perl\lib/unicore/lib/Jg/Lamadh.pl type=file
+c:\perl\lib/unicore/lib/Jg/Meem.pl type=file
+c:\perl\lib/unicore/lib/Jg/Mim.pl type=file
+c:\perl\lib/unicore/lib/Jg/NoJoinin.pl type=file
+c:\perl\lib/unicore/lib/Jg/Noon.pl type=file
+c:\perl\lib/unicore/lib/Jg/Nun.pl type=file
+c:\perl\lib/unicore/lib/Jg/Nya.pl type=file
+c:\perl\lib/unicore/lib/Jg/Pe.pl type=file
+c:\perl\lib/unicore/lib/Jg/Qaf.pl type=file
+c:\perl\lib/unicore/lib/Jg/Qaph.pl type=file
+c:\perl\lib/unicore/lib/Jg/Reh.pl type=file
+c:\perl\lib/unicore/lib/Jg/Reversed.pl type=file
+c:\perl\lib/unicore/lib/Jg/Sad.pl type=file
+c:\perl\lib/unicore/lib/Jg/Sadhe.pl type=file
+c:\perl\lib/unicore/lib/Jg/Seen.pl type=file
+c:\perl\lib/unicore/lib/Jg/Semkath.pl type=file
+c:\perl\lib/unicore/lib/Jg/Shin.pl type=file
+c:\perl\lib/unicore/lib/Jg/SwashKaf.pl type=file
+c:\perl\lib/unicore/lib/Jg/SyriacWa.pl type=file
+c:\perl\lib/unicore/lib/Jg/Tah.pl type=file
+c:\perl\lib/unicore/lib/Jg/Taw.pl type=file
+c:\perl\lib/unicore/lib/Jg/TehMarbu.pl type=file
+c:\perl\lib/unicore/lib/Jg/Teth.pl type=file
+c:\perl\lib/unicore/lib/Jg/Waw.pl type=file
+c:\perl\lib/unicore/lib/Jg/Yeh.pl type=file
+c:\perl\lib/unicore/lib/Jg/YehBarre.pl type=file
+c:\perl\lib/unicore/lib/Jg/YehWithT.pl type=file
+c:\perl\lib/unicore/lib/Jg/Yudh.pl type=file
+c:\perl\lib/unicore/lib/Jg/YudhHe.pl type=file
+c:\perl\lib/unicore/lib/Jg/Zain.pl type=file
+c:\perl\lib/unicore/lib/Jg/Zhain.pl type=file
+c:\perl\lib/unicore/lib/JoinC/N.pl type=file
+c:\perl\lib/unicore/lib/JoinC/Y.pl type=file
+c:\perl\lib/unicore/lib/Jt/C.pl type=file
+c:\perl\lib/unicore/lib/Jt/D.pl type=file
+c:\perl\lib/unicore/lib/Jt/R.pl type=file
+c:\perl\lib/unicore/lib/Jt/T.pl type=file
+c:\perl\lib/unicore/lib/Jt/U.pl type=file
+c:\perl\lib/unicore/lib/LOE/N.pl type=file
+c:\perl\lib/unicore/lib/Lb/AI.pl type=file
+c:\perl\lib/unicore/lib/Lb/AL.pl type=file
+c:\perl\lib/unicore/lib/Lb/B2.pl type=file
+c:\perl\lib/unicore/lib/Lb/BA.pl type=file
+c:\perl\lib/unicore/lib/Lb/BB.pl type=file
+c:\perl\lib/unicore/lib/Lb/BK.pl type=file
+c:\perl\lib/unicore/lib/Lb/CB.pl type=file
+c:\perl\lib/unicore/lib/Lb/CL.pl type=file
+c:\perl\lib/unicore/lib/Lb/CM.pl type=file
+c:\perl\lib/unicore/lib/Lb/CP.pl type=file
+c:\perl\lib/unicore/lib/Lb/EX.pl type=file
+c:\perl\lib/unicore/lib/Lb/GL.pl type=file
+c:\perl\lib/unicore/lib/Lb/HY.pl type=file
+c:\perl\lib/unicore/lib/Lb/ID.pl type=file
+c:\perl\lib/unicore/lib/Lb/IN.pl type=file
+c:\perl\lib/unicore/lib/Lb/IS.pl type=file
+c:\perl\lib/unicore/lib/Lb/NL.pl type=file
+c:\perl\lib/unicore/lib/Lb/NS.pl type=file
+c:\perl\lib/unicore/lib/Lb/NU.pl type=file
+c:\perl\lib/unicore/lib/Lb/OP.pl type=file
+c:\perl\lib/unicore/lib/Lb/PO.pl type=file
+c:\perl\lib/unicore/lib/Lb/PR.pl type=file
+c:\perl\lib/unicore/lib/Lb/QU.pl type=file
+c:\perl\lib/unicore/lib/Lb/SA.pl type=file
+c:\perl\lib/unicore/lib/Lb/SG.pl type=file
+c:\perl\lib/unicore/lib/Lb/SP.pl type=file
+c:\perl\lib/unicore/lib/Lb/SY.pl type=file
+c:\perl\lib/unicore/lib/Lb/WJ.pl type=file
+c:\perl\lib/unicore/lib/Lb/XX.pl type=file
+c:\perl\lib/unicore/lib/Lb/ZW.pl type=file
+c:\perl\lib/unicore/lib/Lower/N.pl type=file
+c:\perl\lib/unicore/lib/Lower/Y.pl type=file
+c:\perl\lib/unicore/lib/Math/N.pl type=file
+c:\perl\lib/unicore/lib/Math/Y.pl type=file
+c:\perl\lib/unicore/lib/NChar/N.pl type=file
+c:\perl\lib/unicore/lib/NChar/Y.pl type=file
+c:\perl\lib/unicore/lib/NFCQC/Y.pl type=file
+c:\perl\lib/unicore/lib/NFDQC/N.pl type=file
+c:\perl\lib/unicore/lib/NFDQC/Y.pl type=file
+c:\perl\lib/unicore/lib/NFKCQC/M.pl type=file
+c:\perl\lib/unicore/lib/NFKCQC/N.pl type=file
+c:\perl\lib/unicore/lib/NFKCQC/Y.pl type=file
+c:\perl\lib/unicore/lib/NFKDQC/N.pl type=file
+c:\perl\lib/unicore/lib/Nt/De.pl type=file
+c:\perl\lib/unicore/lib/Nt/Di.pl type=file
+c:\perl\lib/unicore/lib/Nt/Nu.pl type=file
+c:\perl\lib/unicore/lib/Nv/0.pl type=file
+c:\perl\lib/unicore/lib/Nv/1.pl type=file
+c:\perl\lib/unicore/lib/Nv/10.pl type=file
+c:\perl\lib/unicore/lib/Nv/100.pl type=file
+c:\perl\lib/unicore/lib/Nv/1000.pl type=file
+c:\perl\lib/unicore/lib/Nv/10000.pl type=file
+c:\perl\lib/unicore/lib/Nv/100000.pl type=file
+c:\perl\lib/unicore/lib/Nv/10000000.pl type=file
+c:\perl\lib/unicore/lib/Nv/10000002.pl type=file
+c:\perl\lib/unicore/lib/Nv/11.pl type=file
+c:\perl\lib/unicore/lib/Nv/11_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/12.pl type=file
+c:\perl\lib/unicore/lib/Nv/13.pl type=file
+c:\perl\lib/unicore/lib/Nv/13_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/14.pl type=file
+c:\perl\lib/unicore/lib/Nv/15.pl type=file
+c:\perl\lib/unicore/lib/Nv/15_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/16.pl type=file
+c:\perl\lib/unicore/lib/Nv/17.pl type=file
+c:\perl\lib/unicore/lib/Nv/17_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/18.pl type=file
+c:\perl\lib/unicore/lib/Nv/19.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_10.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_16.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_3.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_4.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_5.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_6.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_7.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_8.pl type=file
+c:\perl\lib/unicore/lib/Nv/1_9.pl type=file
+c:\perl\lib/unicore/lib/Nv/2.pl type=file
+c:\perl\lib/unicore/lib/Nv/20.pl type=file
+c:\perl\lib/unicore/lib/Nv/200.pl type=file
+c:\perl\lib/unicore/lib/Nv/2000.pl type=file
+c:\perl\lib/unicore/lib/Nv/20000.pl type=file
+c:\perl\lib/unicore/lib/Nv/21.pl type=file
+c:\perl\lib/unicore/lib/Nv/22.pl type=file
+c:\perl\lib/unicore/lib/Nv/23.pl type=file
+c:\perl\lib/unicore/lib/Nv/24.pl type=file
+c:\perl\lib/unicore/lib/Nv/25.pl type=file
+c:\perl\lib/unicore/lib/Nv/26.pl type=file
+c:\perl\lib/unicore/lib/Nv/27.pl type=file
+c:\perl\lib/unicore/lib/Nv/28.pl type=file
+c:\perl\lib/unicore/lib/Nv/29.pl type=file
+c:\perl\lib/unicore/lib/Nv/2_3.pl type=file
+c:\perl\lib/unicore/lib/Nv/2_5.pl type=file
+c:\perl\lib/unicore/lib/Nv/3.pl type=file
+c:\perl\lib/unicore/lib/Nv/30.pl type=file
+c:\perl\lib/unicore/lib/Nv/300.pl type=file
+c:\perl\lib/unicore/lib/Nv/3000.pl type=file
+c:\perl\lib/unicore/lib/Nv/30000.pl type=file
+c:\perl\lib/unicore/lib/Nv/31.pl type=file
+c:\perl\lib/unicore/lib/Nv/32.pl type=file
+c:\perl\lib/unicore/lib/Nv/33.pl type=file
+c:\perl\lib/unicore/lib/Nv/34.pl type=file
+c:\perl\lib/unicore/lib/Nv/35.pl type=file
+c:\perl\lib/unicore/lib/Nv/36.pl type=file
+c:\perl\lib/unicore/lib/Nv/37.pl type=file
+c:\perl\lib/unicore/lib/Nv/38.pl type=file
+c:\perl\lib/unicore/lib/Nv/39.pl type=file
+c:\perl\lib/unicore/lib/Nv/3_16.pl type=file
+c:\perl\lib/unicore/lib/Nv/3_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/3_4.pl type=file
+c:\perl\lib/unicore/lib/Nv/3_5.pl type=file
+c:\perl\lib/unicore/lib/Nv/3_8.pl type=file
+c:\perl\lib/unicore/lib/Nv/4.pl type=file
+c:\perl\lib/unicore/lib/Nv/40.pl type=file
+c:\perl\lib/unicore/lib/Nv/400.pl type=file
+c:\perl\lib/unicore/lib/Nv/4000.pl type=file
+c:\perl\lib/unicore/lib/Nv/40000.pl type=file
+c:\perl\lib/unicore/lib/Nv/41.pl type=file
+c:\perl\lib/unicore/lib/Nv/42.pl type=file
+c:\perl\lib/unicore/lib/Nv/43.pl type=file
+c:\perl\lib/unicore/lib/Nv/44.pl type=file
+c:\perl\lib/unicore/lib/Nv/45.pl type=file
+c:\perl\lib/unicore/lib/Nv/46.pl type=file
+c:\perl\lib/unicore/lib/Nv/47.pl type=file
+c:\perl\lib/unicore/lib/Nv/48.pl type=file
+c:\perl\lib/unicore/lib/Nv/49.pl type=file
+c:\perl\lib/unicore/lib/Nv/4_5.pl type=file
+c:\perl\lib/unicore/lib/Nv/5.pl type=file
+c:\perl\lib/unicore/lib/Nv/50.pl type=file
+c:\perl\lib/unicore/lib/Nv/500.pl type=file
+c:\perl\lib/unicore/lib/Nv/5000.pl type=file
+c:\perl\lib/unicore/lib/Nv/50000.pl type=file
+c:\perl\lib/unicore/lib/Nv/5_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/5_6.pl type=file
+c:\perl\lib/unicore/lib/Nv/5_8.pl type=file
+c:\perl\lib/unicore/lib/Nv/6.pl type=file
+c:\perl\lib/unicore/lib/Nv/60.pl type=file
+c:\perl\lib/unicore/lib/Nv/600.pl type=file
+c:\perl\lib/unicore/lib/Nv/6000.pl type=file
+c:\perl\lib/unicore/lib/Nv/60000.pl type=file
+c:\perl\lib/unicore/lib/Nv/7.pl type=file
+c:\perl\lib/unicore/lib/Nv/70.pl type=file
+c:\perl\lib/unicore/lib/Nv/700.pl type=file
+c:\perl\lib/unicore/lib/Nv/7000.pl type=file
+c:\perl\lib/unicore/lib/Nv/70000.pl type=file
+c:\perl\lib/unicore/lib/Nv/7_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/7_8.pl type=file
+c:\perl\lib/unicore/lib/Nv/8.pl type=file
+c:\perl\lib/unicore/lib/Nv/80.pl type=file
+c:\perl\lib/unicore/lib/Nv/800.pl type=file
+c:\perl\lib/unicore/lib/Nv/8000.pl type=file
+c:\perl\lib/unicore/lib/Nv/80000.pl type=file
+c:\perl\lib/unicore/lib/Nv/9.pl type=file
+c:\perl\lib/unicore/lib/Nv/90.pl type=file
+c:\perl\lib/unicore/lib/Nv/900.pl type=file
+c:\perl\lib/unicore/lib/Nv/9000.pl type=file
+c:\perl\lib/unicore/lib/Nv/90000.pl type=file
+c:\perl\lib/unicore/lib/Nv/9_2.pl type=file
+c:\perl\lib/unicore/lib/Nv/NaN.pl type=file
+c:\perl\lib/unicore/lib/Nv/_1_2.pl type=file
+c:\perl\lib/unicore/lib/OAlpha/N.pl type=file
+c:\perl\lib/unicore/lib/OAlpha/Y.pl type=file
+c:\perl\lib/unicore/lib/ODI/N.pl type=file
+c:\perl\lib/unicore/lib/ODI/Y.pl type=file
+c:\perl\lib/unicore/lib/OGrExt/N.pl type=file
+c:\perl\lib/unicore/lib/OGrExt/Y.pl type=file
+c:\perl\lib/unicore/lib/OIDC/N.pl type=file
+c:\perl\lib/unicore/lib/OIDC/Y.pl type=file
+c:\perl\lib/unicore/lib/OIDS/N.pl type=file
+c:\perl\lib/unicore/lib/OIDS/Y.pl type=file
+c:\perl\lib/unicore/lib/OLower/N.pl type=file
+c:\perl\lib/unicore/lib/OLower/Y.pl type=file
+c:\perl\lib/unicore/lib/OMath/N.pl type=file
+c:\perl\lib/unicore/lib/OMath/Y.pl type=file
+c:\perl\lib/unicore/lib/OUpper/N.pl type=file
+c:\perl\lib/unicore/lib/OUpper/Y.pl type=file
+c:\perl\lib/unicore/lib/PatSyn/N.pl type=file
+c:\perl\lib/unicore/lib/PatSyn/Y.pl type=file
+c:\perl\lib/unicore/lib/PatWS/N.pl type=file
+c:\perl\lib/unicore/lib/PatWS/Y.pl type=file
+c:\perl\lib/unicore/lib/Perl/Alnum.pl type=file
+c:\perl\lib/unicore/lib/Perl/Any.pl type=file
+c:\perl\lib/unicore/lib/Perl/Assigned.pl type=file
+c:\perl\lib/unicore/lib/Perl/Blank.pl type=file
+c:\perl\lib/unicore/lib/Perl/Graph.pl type=file
+c:\perl\lib/unicore/lib/Perl/PerlSpac.pl type=file
+c:\perl\lib/unicore/lib/Perl/PerlWord.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixAln.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixAlp.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixBla.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixCnt.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixDig.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixGra.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixLow.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixPri.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixPun.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixSpa.pl type=file
+c:\perl\lib/unicore/lib/Perl/PosixUpp.pl type=file
+c:\perl\lib/unicore/lib/Perl/Print.pl type=file
+c:\perl\lib/unicore/lib/Perl/SpacePer.pl type=file
+c:\perl\lib/unicore/lib/Perl/VertSpac.pl type=file
+c:\perl\lib/unicore/lib/Perl/Word.pl type=file
+c:\perl\lib/unicore/lib/Perl/_XBegin.pl type=file
+c:\perl\lib/unicore/lib/Perl/_XExtend.pl type=file
+c:\perl\lib/unicore/lib/Perl/_XLVLVTV.pl type=file
+c:\perl\lib/unicore/lib/QMark/N.pl type=file
+c:\perl\lib/unicore/lib/QMark/Y.pl type=file
+c:\perl\lib/unicore/lib/Radical/N.pl type=file
+c:\perl\lib/unicore/lib/Radical/Y.pl type=file
+c:\perl\lib/unicore/lib/SB/AT.pl type=file
+c:\perl\lib/unicore/lib/SB/CL.pl type=file
+c:\perl\lib/unicore/lib/SB/EX.pl type=file
+c:\perl\lib/unicore/lib/SB/FO.pl type=file
+c:\perl\lib/unicore/lib/SB/LE.pl type=file
+c:\perl\lib/unicore/lib/SB/LO.pl type=file
+c:\perl\lib/unicore/lib/SB/SC.pl type=file
+c:\perl\lib/unicore/lib/SB/SE.pl type=file
+c:\perl\lib/unicore/lib/SB/ST.pl type=file
+c:\perl\lib/unicore/lib/SB/Sp.pl type=file
+c:\perl\lib/unicore/lib/SB/UP.pl type=file
+c:\perl\lib/unicore/lib/SB/XX.pl type=file
+c:\perl\lib/unicore/lib/SD/N.pl type=file
+c:\perl\lib/unicore/lib/SD/Y.pl type=file
+c:\perl\lib/unicore/lib/STerm/N.pl type=file
+c:\perl\lib/unicore/lib/STerm/Y.pl type=file
+c:\perl\lib/unicore/lib/Sc/Arab.pl type=file
+c:\perl\lib/unicore/lib/Sc/Armi.pl type=file
+c:\perl\lib/unicore/lib/Sc/Armn.pl type=file
+c:\perl\lib/unicore/lib/Sc/Avst.pl type=file
+c:\perl\lib/unicore/lib/Sc/Bali.pl type=file
+c:\perl\lib/unicore/lib/Sc/Bamu.pl type=file
+c:\perl\lib/unicore/lib/Sc/Beng.pl type=file
+c:\perl\lib/unicore/lib/Sc/Bopo.pl type=file
+c:\perl\lib/unicore/lib/Sc/Bugi.pl type=file
+c:\perl\lib/unicore/lib/Sc/Buhd.pl type=file
+c:\perl\lib/unicore/lib/Sc/Cans.pl type=file
+c:\perl\lib/unicore/lib/Sc/Cari.pl type=file
+c:\perl\lib/unicore/lib/Sc/Cham.pl type=file
+c:\perl\lib/unicore/lib/Sc/Cher.pl type=file
+c:\perl\lib/unicore/lib/Sc/Copt.pl type=file
+c:\perl\lib/unicore/lib/Sc/Cprt.pl type=file
+c:\perl\lib/unicore/lib/Sc/Cyrl.pl type=file
+c:\perl\lib/unicore/lib/Sc/Deva.pl type=file
+c:\perl\lib/unicore/lib/Sc/Egyp.pl type=file
+c:\perl\lib/unicore/lib/Sc/Ethi.pl type=file
+c:\perl\lib/unicore/lib/Sc/Geor.pl type=file
+c:\perl\lib/unicore/lib/Sc/Glag.pl type=file
+c:\perl\lib/unicore/lib/Sc/Goth.pl type=file
+c:\perl\lib/unicore/lib/Sc/Grek.pl type=file
+c:\perl\lib/unicore/lib/Sc/Gujr.pl type=file
+c:\perl\lib/unicore/lib/Sc/Guru.pl type=file
+c:\perl\lib/unicore/lib/Sc/Han.pl type=file
+c:\perl\lib/unicore/lib/Sc/Hang.pl type=file
+c:\perl\lib/unicore/lib/Sc/Hano.pl type=file
+c:\perl\lib/unicore/lib/Sc/Hebr.pl type=file
+c:\perl\lib/unicore/lib/Sc/Hira.pl type=file
+c:\perl\lib/unicore/lib/Sc/Ital.pl type=file
+c:\perl\lib/unicore/lib/Sc/Java.pl type=file
+c:\perl\lib/unicore/lib/Sc/Kana.pl type=file
+c:\perl\lib/unicore/lib/Sc/Khar.pl type=file
+c:\perl\lib/unicore/lib/Sc/Khmr.pl type=file
+c:\perl\lib/unicore/lib/Sc/Knda.pl type=file
+c:\perl\lib/unicore/lib/Sc/Kthi.pl type=file
+c:\perl\lib/unicore/lib/Sc/Lana.pl type=file
+c:\perl\lib/unicore/lib/Sc/Lao.pl type=file
+c:\perl\lib/unicore/lib/Sc/Latn.pl type=file
+c:\perl\lib/unicore/lib/Sc/Lepc.pl type=file
+c:\perl\lib/unicore/lib/Sc/Limb.pl type=file
+c:\perl\lib/unicore/lib/Sc/Linb.pl type=file
+c:\perl\lib/unicore/lib/Sc/Lyci.pl type=file
+c:\perl\lib/unicore/lib/Sc/Lydi.pl type=file
+c:\perl\lib/unicore/lib/Sc/Mlym.pl type=file
+c:\perl\lib/unicore/lib/Sc/Mong.pl type=file
+c:\perl\lib/unicore/lib/Sc/Mtei.pl type=file
+c:\perl\lib/unicore/lib/Sc/Mymr.pl type=file
+c:\perl\lib/unicore/lib/Sc/Nko.pl type=file
+c:\perl\lib/unicore/lib/Sc/Ogam.pl type=file
+c:\perl\lib/unicore/lib/Sc/Orkh.pl type=file
+c:\perl\lib/unicore/lib/Sc/Orya.pl type=file
+c:\perl\lib/unicore/lib/Sc/Osma.pl type=file
+c:\perl\lib/unicore/lib/Sc/Phag.pl type=file
+c:\perl\lib/unicore/lib/Sc/Phli.pl type=file
+c:\perl\lib/unicore/lib/Sc/Phnx.pl type=file
+c:\perl\lib/unicore/lib/Sc/Prti.pl type=file
+c:\perl\lib/unicore/lib/Sc/Rjng.pl type=file
+c:\perl\lib/unicore/lib/Sc/Runr.pl type=file
+c:\perl\lib/unicore/lib/Sc/Samr.pl type=file
+c:\perl\lib/unicore/lib/Sc/Saur.pl type=file
+c:\perl\lib/unicore/lib/Sc/Sinh.pl type=file
+c:\perl\lib/unicore/lib/Sc/Sund.pl type=file
+c:\perl\lib/unicore/lib/Sc/Sylo.pl type=file
+c:\perl\lib/unicore/lib/Sc/Syrc.pl type=file
+c:\perl\lib/unicore/lib/Sc/Tagb.pl type=file
+c:\perl\lib/unicore/lib/Sc/Tale.pl type=file
+c:\perl\lib/unicore/lib/Sc/Talu.pl type=file
+c:\perl\lib/unicore/lib/Sc/Taml.pl type=file
+c:\perl\lib/unicore/lib/Sc/Tavt.pl type=file
+c:\perl\lib/unicore/lib/Sc/Telu.pl type=file
+c:\perl\lib/unicore/lib/Sc/Tfng.pl type=file
+c:\perl\lib/unicore/lib/Sc/Tglg.pl type=file
+c:\perl\lib/unicore/lib/Sc/Thaa.pl type=file
+c:\perl\lib/unicore/lib/Sc/Thai.pl type=file
+c:\perl\lib/unicore/lib/Sc/Tibt.pl type=file
+c:\perl\lib/unicore/lib/Sc/Ugar.pl type=file
+c:\perl\lib/unicore/lib/Sc/Vai.pl type=file
+c:\perl\lib/unicore/lib/Sc/Xpeo.pl type=file
+c:\perl\lib/unicore/lib/Sc/Xsux.pl type=file
+c:\perl\lib/unicore/lib/Sc/Yi.pl type=file
+c:\perl\lib/unicore/lib/Sc/Zinh.pl type=file
+c:\perl\lib/unicore/lib/Sc/Zyyy.pl type=file
+c:\perl\lib/unicore/lib/Sc/Zzzz.pl type=file
+c:\perl\lib/unicore/lib/Space/N.pl type=file
+c:\perl\lib/unicore/lib/Space/Y.pl type=file
+c:\perl\lib/unicore/lib/Term/N.pl type=file
+c:\perl\lib/unicore/lib/Term/Y.pl type=file
+c:\perl\lib/unicore/lib/UIdeo/N.pl type=file
+c:\perl\lib/unicore/lib/UIdeo/Y.pl type=file
+c:\perl\lib/unicore/lib/Upper/N.pl type=file
+c:\perl\lib/unicore/lib/Upper/Y.pl type=file
+c:\perl\lib/unicore/lib/VS/N.pl type=file
+c:\perl\lib/unicore/lib/VS/Y.pl type=file
+c:\perl\lib/unicore/lib/WB/EX.pl type=file
+c:\perl\lib/unicore/lib/WB/FO.pl type=file
+c:\perl\lib/unicore/lib/WB/KA.pl type=file
+c:\perl\lib/unicore/lib/WB/LE.pl type=file
+c:\perl\lib/unicore/lib/WB/MB.pl type=file
+c:\perl\lib/unicore/lib/WB/ML.pl type=file
+c:\perl\lib/unicore/lib/WB/MN.pl type=file
+c:\perl\lib/unicore/lib/WB/NL.pl type=file
+c:\perl\lib/unicore/lib/WB/NU.pl type=file
+c:\perl\lib/unicore/lib/WB/XX.pl type=file
+c:\perl\lib/unicore/lib/XIDC/N.pl type=file
+c:\perl\lib/unicore/lib/XIDC/Y.pl type=file
+c:\perl\lib/unicore/lib/XIDS/N.pl type=file
+c:\perl\lib/unicore/lib/XIDS/Y.pl type=file
+c:\perl\lib/unicore/mktables type=file
+c:\perl\lib/unicore/mktables.lst type=file
+c:\perl\lib/unicore/version type=file
+c:\perl\lib/utf8.pm type=file
+c:\perl\lib/utf8_heavy.pl type=file
+c:\perl\lib/validate.pl type=file
+c:\perl\lib/vars.pm type=file
+c:\perl\lib/version.pm type=file
+c:\perl\lib/version.pod type=file
+c:\perl\lib/version/Internals.pod type=file
+c:\perl\lib/vmsish.pm type=file
+c:\perl\lib/warnings.pm type=file
+c:\perl\lib/warnings/register.pm type=file
diff --git a/Master/tlpkg/tlperl/lib/AnyDBM_File.pm b/Master/tlpkg/tlperl/lib/AnyDBM_File.pm
new file mode 100644
index 00000000000..d73abab0f9e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/AnyDBM_File.pm
@@ -0,0 +1,93 @@
+package AnyDBM_File;
+
+use 5.006_001;
+our $VERSION = '1.00';
+our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
+
+my $mod;
+for $mod (@ISA) {
+ if (eval "require $mod") {
+ @ISA = ($mod); # if we leave @ISA alone, warnings abound
+ return 1;
+ }
+}
+
+die "No DBM package was successfully found or installed";
+#return 0;
+
+=head1 NAME
+
+AnyDBM_File - provide framework for multiple DBMs
+
+NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
+
+=head1 SYNOPSIS
+
+ use AnyDBM_File;
+
+=head1 DESCRIPTION
+
+This module is a "pure virtual base class"--it has nothing of its own.
+It's just there to inherit from one of the various DBM packages. It
+prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
+L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
+finally ODBM. This way old programs that used to use NDBM via dbmopen()
+can still do so, but new ones can reorder @ISA:
+
+ BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
+ use AnyDBM_File;
+
+Having multiple DBM implementations makes it trivial to copy database formats:
+
+ use POSIX; use NDBM_File; use DB_File;
+ tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
+ tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
+ %newhash = %oldhash;
+
+=head2 DBM Comparisons
+
+Here's a partial table of features the different packages offer:
+
+ odbm ndbm sdbm gdbm bsd-db
+ ---- ---- ---- ---- ------
+ Linkage comes w/ perl yes yes yes yes yes
+ Src comes w/ perl no no yes no no
+ Comes w/ many unix os yes yes[0] no no no
+ Builds ok on !unix ? ? yes yes ?
+ Code Size ? ? small big big
+ Database Size ? ? small big? ok[1]
+ Speed ? ? slow ok fast
+ FTPable no no yes yes yes
+ Easy to build N/A N/A yes yes ok[2]
+ Size limits 1k 4k 1k[3] none none
+ Byte-order independent no no no no yes
+ Licensing restrictions ? ? no yes no
+
+
+=over 4
+
+=item [0]
+
+on mixed universe machines, may be in the bsd compat library,
+which is often shunned.
+
+=item [1]
+
+Can be trimmed if you compile for one access method.
+
+=item [2]
+
+See L<DB_File>.
+Requires symbolic links.
+
+=item [3]
+
+By default, but can be redefined.
+
+=back
+
+=head1 SEE ALSO
+
+dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/AutoLoader.pm b/Master/tlpkg/tlperl/lib/AutoLoader.pm
new file mode 100644
index 00000000000..06f986b50d6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/AutoLoader.pm
@@ -0,0 +1,429 @@
+package AutoLoader;
+
+use strict;
+use 5.006_001;
+
+our($VERSION, $AUTOLOAD);
+
+my $is_dosish;
+my $is_epoc;
+my $is_vms;
+my $is_macos;
+
+BEGIN {
+ $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
+ $is_epoc = $^O eq 'epoc';
+ $is_vms = $^O eq 'VMS';
+ $is_macos = $^O eq 'MacOS';
+ $VERSION = '5.70';
+}
+
+AUTOLOAD {
+ my $sub = $AUTOLOAD;
+ my $filename = AutoLoader::find_filename( $sub );
+
+ my $save = $@;
+ local $!; # Do not munge the value.
+ eval { local $SIG{__DIE__}; require $filename };
+ if ($@) {
+ if (substr($sub,-9) eq '::DESTROY') {
+ no strict 'refs';
+ *$sub = sub {};
+ $@ = undef;
+ } elsif ($@ =~ /^Can't locate/) {
+ # The load might just have failed because the filename was too
+ # long for some old SVR3 systems which treat long names as errors.
+ # If we can successfully truncate a long name then it's worth a go.
+ # There is a slight risk that we could pick up the wrong file here
+ # but autosplit should have warned about that when splitting.
+ if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
+ eval { local $SIG{__DIE__}; require $filename };
+ }
+ }
+ if ($@){
+ $@ =~ s/ at .*\n//;
+ my $error = $@;
+ require Carp;
+ Carp::croak($error);
+ }
+ }
+ $@ = $save;
+ goto &$sub;
+}
+
+sub find_filename {
+ my $sub = shift;
+ my $filename;
+ # Braces used to preserve $1 et al.
+ {
+ # Try to find the autoloaded file from the package-qualified
+ # name of the sub. e.g., if the sub needed is
+ # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
+ # something like '/usr/lib/perl5/Getopt/Long.pm', and the
+ # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
+ # 'lib/Getopt/Long.pm', and we want to require
+ # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
+ # In this case, we simple prepend the 'auto/' and let the
+ # C<require> take care of the searching for us.
+
+ my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
+ $pkg =~ s#::#/#g;
+ if (defined($filename = $INC{"$pkg.pm"})) {
+ if ($is_macos) {
+ $pkg =~ tr#/#:#;
+ $filename = undef
+ unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
+ } else {
+ $filename = undef
+ unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
+ }
+
+ # if the file exists, then make sure that it is a
+ # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
+ # or './lib/auto/foo/bar.al'. This avoids C<require> searching
+ # (and failing) to find the 'lib/auto/foo/bar.al' because it
+ # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
+
+ if (defined $filename and -r $filename) {
+ unless ($filename =~ m|^/|s) {
+ if ($is_dosish) {
+ unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
+ if ($^O ne 'NetWare') {
+ $filename = "./$filename";
+ } else {
+ $filename = "$filename";
+ }
+ }
+ }
+ elsif ($is_epoc) {
+ unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
+ $filename = "./$filename";
+ }
+ }
+ elsif ($is_vms) {
+ # XXX todo by VMSmiths
+ $filename = "./$filename";
+ }
+ elsif (!$is_macos) {
+ $filename = "./$filename";
+ }
+ }
+ }
+ else {
+ $filename = undef;
+ }
+ }
+ unless (defined $filename) {
+ # let C<require> do the searching
+ $filename = "auto/$sub.al";
+ $filename =~ s#::#/#g;
+ }
+ }
+ return $filename;
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+
+ #
+ # Export symbols, but not by accident of inheritance.
+ #
+
+ if ($pkg eq 'AutoLoader') {
+ if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) {
+ no strict 'refs';
+ *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD;
+ }
+ }
+
+ #
+ # Try to find the autosplit index file. Eg., if the call package
+ # is POSIX, then $INC{POSIX.pm} is something like
+ # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
+ # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then
+ # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
+ # 'auto/POSIX/autosplit.ix' (without the leading 'lib').
+ #
+
+ (my $calldir = $callpkg) =~ s#::#/#g;
+ my $path = $INC{$calldir . '.pm'};
+ if (defined($path)) {
+ # Try absolute path name, but only eval it if the
+ # transformation from module path to autosplit.ix path
+ # succeeded!
+ my $replaced_okay;
+ if ($is_macos) {
+ (my $malldir = $calldir) =~ tr#/#:#;
+ $replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s);
+ } else {
+ $replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#);
+ }
+
+ eval { require $path; } if $replaced_okay;
+ # If that failed, try relative path with normal @INC searching.
+ if (!$replaced_okay or $@) {
+ $path ="auto/$calldir/autosplit.ix";
+ eval { require $path; };
+ }
+ if ($@) {
+ my $error = $@;
+ require Carp;
+ Carp::carp($error);
+ }
+ }
+}
+
+sub unimport {
+ my $callpkg = caller;
+
+ no strict 'refs';
+
+ for my $exported (qw( AUTOLOAD )) {
+ my $symname = $callpkg . '::' . $exported;
+ undef *{ $symname } if \&{ $symname } == \&{ $exported };
+ *{ $symname } = \&{ $symname };
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+AutoLoader - load subroutines only on demand
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
+
+ package Bar;
+ use AutoLoader; # don't import AUTOLOAD, define our own
+ sub AUTOLOAD {
+ ...
+ $AutoLoader::AUTOLOAD = "...";
+ goto &AutoLoader::AUTOLOAD;
+ }
+
+=head1 DESCRIPTION
+
+The B<AutoLoader> module works with the B<AutoSplit> module and the
+C<__END__> token to defer the loading of some subroutines until they are
+used rather than loading them all at once.
+
+To use B<AutoLoader>, the author of a module has to place the
+definitions of subroutines to be autoloaded after an C<__END__> token.
+(See L<perldata>.) The B<AutoSplit> module can then be run manually to
+extract the definitions into individual files F<auto/funcname.al>.
+
+B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
+subroutine in is called in a client module of B<AutoLoader>,
+B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
+file with a name related to the location of the file from which the
+client module was read. As an example, if F<POSIX.pm> is located in
+F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
+subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
+the C<.al> file has the same name as the subroutine, sans package. If
+such a file exists, AUTOLOAD will read and evaluate it,
+thus (presumably) defining the needed subroutine. AUTOLOAD will then
+C<goto> the newly defined subroutine.
+
+Once this process completes for a given function, it is defined, so
+future calls to the subroutine will bypass the AUTOLOAD mechanism.
+
+=head2 Subroutine Stubs
+
+In order for object method lookup and/or prototype checking to operate
+correctly even when methods have not yet been defined it is necessary to
+"forward declare" each subroutine (as in C<sub NAME;>). See
+L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
+stubs", which are place holders with no code.
+
+The AutoSplit and B<AutoLoader> modules automate the creation of forward
+declarations. The AutoSplit module creates an 'index' file containing
+forward declarations of all the AutoSplit subroutines. When the
+AutoLoader module is 'use'd it loads these declarations into its callers
+package.
+
+Because of this mechanism it is important that B<AutoLoader> is always
+C<use>d and not C<require>d.
+
+=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
+
+In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
+explicitly import it:
+
+ use AutoLoader 'AUTOLOAD';
+
+=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
+
+Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
+They typically need to check for some special cases (such as constants)
+and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
+
+Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
+Instead, they should define their own AUTOLOAD subroutines along these
+lines:
+
+ use AutoLoader;
+ use Carp;
+
+ sub AUTOLOAD {
+ my $sub = $AUTOLOAD;
+ (my $constname = $sub) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/ || $!{EINVAL}) {
+ $AutoLoader::AUTOLOAD = $sub;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined constant $constname";
+ }
+ }
+ *$sub = sub { $val }; # same as: eval "sub $sub { $val }";
+ goto &$sub;
+ }
+
+If any module's own AUTOLOAD subroutine has no need to fallback to the
+AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
+subroutines), then that module should not use B<AutoLoader> at all.
+
+=head2 Package Lexicals
+
+Package lexicals declared with C<my> in the main block of a package
+using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
+the fact that the given scope ends at the C<__END__> marker. A module
+using such variables as package globals will not work properly under the
+B<AutoLoader>.
+
+The C<vars> pragma (see L<perlmod/"vars">) may be used in such
+situations as an alternative to explicitly qualifying all globals with
+the package namespace. Variables pre-declared with this pragma will be
+visible to any autoloaded routines (but will not be invisible outside
+the package, unfortunately).
+
+=head2 Not Using AutoLoader
+
+You can stop using AutoLoader by simply
+
+ no AutoLoader;
+
+=head2 B<AutoLoader> vs. B<SelfLoader>
+
+The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
+loading of subroutines.
+
+B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
+While this avoids the use of a hierarchy of disk files and the
+associated open/close for each routine loaded, B<SelfLoader> suffers a
+startup speed disadvantage in the one-time parsing of the lines after
+C<__DATA__>, after which routines are cached. B<SelfLoader> can also
+handle multiple packages in a file.
+
+B<AutoLoader> only reads code as it is requested, and in many cases
+should be faster, but requires a mechanism like B<AutoSplit> be used to
+create the individual files. L<ExtUtils::MakeMaker> will invoke
+B<AutoSplit> automatically if B<AutoLoader> is used in a module source
+file.
+
+=head1 CAVEATS
+
+AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
+old modules which use B<AutoLoader> should be changed to the new calling
+style. Typically this just means changing a require to a use, adding
+the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
+from C<@ISA>.
+
+On systems with restrictions on file name length, the file corresponding
+to a subroutine may have a shorter name that the routine itself. This
+can lead to conflicting file names. The I<AutoSplit> package warns of
+these potential conflicts when used to split a module.
+
+AutoLoader may fail to find the autosplit files (or even find the wrong
+ones) in cases where C<@INC> contains relative paths, B<and> the program
+does C<chdir>.
+
+=head1 SEE ALSO
+
+L<SelfLoader> - an autoloader that doesn't use external files.
+
+=head1 AUTHOR
+
+C<AutoLoader> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since the first release
+of perl5. It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core:
+
+ Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ by Larry Wall and others
+
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program in the file named "Copying". If not, write to the
+ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307, USA or visit their web page on the internet at
+ http://www.gnu.org/copyleft/gpl.html.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/AutoSplit.pm b/Master/tlpkg/tlperl/lib/AutoSplit.pm
new file mode 100644
index 00000000000..c093f2dd24b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/AutoSplit.pm
@@ -0,0 +1,592 @@
+package AutoSplit;
+
+use Exporter ();
+use Config qw(%Config);
+use File::Basename ();
+use File::Path qw(mkpath);
+use File::Spec::Functions qw(curdir catfile catdir);
+use strict;
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
+ $CheckForAutoloader, $CheckModTime);
+
+$VERSION = "1.06";
+@ISA = qw(Exporter);
+@EXPORT = qw(&autosplit &autosplit_lib_modules);
+@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
+
+=head1 NAME
+
+AutoSplit - split a package for autoloading
+
+=head1 SYNOPSIS
+
+ autosplit($file, $dir, $keep, $check, $modtime);
+
+ autosplit_lib_modules(@modules);
+
+=head1 DESCRIPTION
+
+This function will split up your program into files that the AutoLoader
+module can handle. It is used by both the standard perl libraries and by
+the MakeMaker utility, to automatically configure libraries for autoloading.
+
+The C<autosplit> interface splits the specified file into a hierarchy
+rooted at the directory C<$dir>. It creates directories as needed to reflect
+class hierarchy, and creates the file F<autosplit.ix>. This file acts as
+both forward declaration of all package routines, and as timestamp for the
+last update of the hierarchy.
+
+The remaining three arguments to C<autosplit> govern other options to
+the autosplitter.
+
+=over 2
+
+=item $keep
+
+If the third argument, I<$keep>, is false, then any
+pre-existing C<*.al> files in the autoload directory are removed if
+they are no longer part of the module (obsoleted functions).
+$keep defaults to 0.
+
+=item $check
+
+The
+fourth argument, I<$check>, instructs C<autosplit> to check the module
+currently being split to ensure that it includes a C<use>
+specification for the AutoLoader module, and skips the module if
+AutoLoader is not detected.
+$check defaults to 1.
+
+=item $modtime
+
+Lastly, the I<$modtime> argument specifies
+that C<autosplit> is to check the modification time of the module
+against that of the C<autosplit.ix> file, and only split the module if
+it is newer.
+$modtime defaults to 1.
+
+=back
+
+Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
+with:
+
+ perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
+
+Defined as a Make macro, it is invoked with file and directory arguments;
+C<autosplit> will split the specified file into the specified directory and
+delete obsolete C<.al> files, after checking first that the module does use
+the AutoLoader, and ensuring that the module is not already currently split
+in its current form (the modtime test).
+
+The C<autosplit_lib_modules> form is used in the building of perl. It takes
+as input a list of files (modules) that are assumed to reside in a directory
+B<lib> relative to the current directory. Each file is sent to the
+autosplitter one at a time, to be split into the directory B<lib/auto>.
+
+In both usages of the autosplitter, only subroutines defined following the
+perl I<__END__> token are split out into separate files. Some
+routines may be placed prior to this marker to force their immediate loading
+and parsing.
+
+=head2 Multiple packages
+
+As of version 1.01 of the AutoSplit module it is possible to have
+multiple packages within a single file. Both of the following cases
+are supported:
+
+ package NAME;
+ __END__
+ sub AAA { ... }
+ package NAME::option1;
+ sub BBB { ... }
+ package NAME::option2;
+ sub BBB { ... }
+
+ package NAME;
+ __END__
+ sub AAA { ... }
+ sub NAME::option1::BBB { ... }
+ sub NAME::option2::BBB { ... }
+
+=head1 DIAGNOSTICS
+
+C<AutoSplit> will inform the user if it is necessary to create the
+top-level directory specified in the invocation. It is preferred that
+the script or installation process that invokes C<AutoSplit> have
+created the full directory path ahead of time. This warning may
+indicate that the module is being split into an incorrect path.
+
+C<AutoSplit> will warn the user of all subroutines whose name causes
+potential file naming conflicts on machines with drastically limited
+(8 characters or less) file name length. Since the subroutine name is
+used as the file name, these warnings can aid in portability to such
+systems.
+
+Warnings are issued and the file skipped if C<AutoSplit> cannot locate
+either the I<__END__> marker or a "package Name;"-style specification.
+
+C<AutoSplit> will also emit general diagnostics for inability to
+create directories or files.
+
+=head1 AUTHOR
+
+C<AutoSplit> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since the first release
+of perl5. It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core:
+
+ Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ by Larry Wall and others
+
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program in the file named "Copying". If not, write to the
+ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307, USA or visit their web page on the internet at
+ http://www.gnu.org/copyleft/gpl.html.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+=cut
+
+# for portability warn about names longer than $maxlen
+$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
+$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
+$Keep = 0;
+$CheckForAutoloader = 1;
+$CheckModTime = 1;
+
+my $IndexFile = "autosplit.ix"; # file also serves as timestamp
+my $maxflen = 255;
+$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
+if (defined (&Dos::UseLFN)) {
+ $maxflen = Dos::UseLFN() ? 255 : 11;
+}
+my $Is_VMS = ($^O eq 'VMS');
+
+# allow checking for valid ': attrlist' attachments.
+# extra jugglery required to support both 5.8 and 5.9/5.10 features
+# (support for 5.8 required for cross-compiling environments)
+
+my $attr_list =
+ $] >= 5.009005 ?
+ eval <<'__QR__'
+ qr{
+ \s* : \s*
+ (?:
+ # one attribute
+ (?> # no backtrack
+ (?! \d) \w+
+ (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
+ )
+ (?: \s* : \s* | \s+ (?! :) )
+ )*
+ }x
+__QR__
+ :
+ do {
+ # In pre-5.9.5 world we have to do dirty tricks.
+ # (we use 'our' rather than 'my' here, due to the rather complex and buggy
+ # behaviour of lexicals with qr// and (??{$lex}) )
+ our $trick1; # yes, cannot our and assign at the same time.
+ $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
+ our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
+ qr{ \s* : \s* (?: $trick2 )* }x;
+ };
+
+sub autosplit{
+ my($file, $autodir, $keep, $ckal, $ckmt) = @_;
+ # $file - the perl source file to be split (after __END__)
+ # $autodir - the ".../auto" dir below which to write split subs
+ # Handle optional flags:
+ $keep = $Keep unless defined $keep;
+ $ckal = $CheckForAutoloader unless defined $ckal;
+ $ckmt = $CheckModTime unless defined $ckmt;
+ autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
+}
+
+sub carp{
+ require Carp;
+ goto &Carp::carp;
+}
+
+# This function is used during perl building/installation
+# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
+
+sub autosplit_lib_modules {
+ my(@modules) = @_; # list of Module names
+ local $_; # Avoid clobber.
+ while (defined($_ = shift @modules)) {
+ while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
+ $_ = catfile($1, $2);
+ }
+ s|\\|/|g; # bug in ksh OS/2
+ s#^lib/##s; # incase specified as lib/*.pm
+ my($lib) = catfile(curdir(), "lib");
+ if ($Is_VMS) { # may need to convert VMS-style filespecs
+ $lib =~ s#^\[\]#.\/#;
+ }
+ s#^$lib\W+##s; # incase specified as ./lib/*.pm
+ if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
+ my ($dir,$name) = (/(.*])(.*)/s);
+ $dir =~ s/.*lib[\.\]]//s;
+ $dir =~ s#[\.\]]#/#g;
+ $_ = $dir . $name;
+ }
+ autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
+ $Keep, $CheckForAutoloader, $CheckModTime);
+ }
+ 0;
+}
+
+
+# private functions
+
+my $self_mod_time = (stat __FILE__)[9];
+
+sub autosplit_file {
+ my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
+ = @_;
+ my(@outfiles);
+ local($_);
+ local($/) = "\n";
+
+ # where to write output files
+ $autodir ||= catfile(curdir(), "lib", "auto");
+ if ($Is_VMS) {
+ ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
+ $filename = VMS::Filespec::unixify($filename); # may have dirs
+ }
+ unless (-d $autodir){
+ mkpath($autodir,0,0755);
+ # We should never need to create the auto dir
+ # here. installperl (or similar) should have done
+ # it. Expecting it to exist is a valuable sanity check against
+ # autosplitting into some random directory by mistake.
+ print "Warning: AutoSplit had to create top-level " .
+ "$autodir unexpectedly.\n";
+ }
+
+ # allow just a package name to be used
+ $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
+
+ open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
+ my($pm_mod_time) = (stat($filename))[9];
+ my($autoloader_seen) = 0;
+ my($in_pod) = 0;
+ my($def_package,$last_package,$this_package,$fnr);
+ while (<$in>) {
+ # Skip pod text.
+ $fnr++;
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/);
+ next if /^\s*#/;
+
+ # record last package name seen
+ $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
+ ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
+ ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
+ last if /^__END__/;
+ }
+ if ($check_for_autoloader && !$autoloader_seen){
+ print "AutoSplit skipped $filename: no AutoLoader used\n"
+ if ($Verbose>=2);
+ return 0;
+ }
+ $_ or die "Can't find __END__ in $filename\n";
+
+ $def_package or die "Can't find 'package Name;' in $filename\n";
+
+ my($modpname) = _modpname($def_package);
+
+ # this _has_ to match so we have a reasonable timestamp file
+ die "Package $def_package ($modpname.pm) does not ".
+ "match filename $filename"
+ unless ($filename =~ m/\Q$modpname.pm\E$/ or
+ ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
+ $Is_VMS && $filename =~ m/$modpname.pm/i);
+
+ my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
+
+ if ($check_mod_time){
+ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
+ if ($al_ts_time >= $pm_mod_time and
+ $al_ts_time >= $self_mod_time){
+ print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
+ if ($Verbose >= 2);
+ return undef; # one undef, not a list
+ }
+ }
+
+ my($modnamedir) = catdir($autodir, $modpname);
+ print "AutoSplitting $filename ($modnamedir)\n"
+ if $Verbose;
+
+ unless (-d $modnamedir){
+ mkpath($modnamedir,0,0777);
+ }
+
+ # We must try to deal with some SVR3 systems with a limit of 14
+ # characters for file names. Sadly we *cannot* simply truncate all
+ # file names to 14 characters on these systems because we *must*
+ # create filenames which exactly match the names used by AutoLoader.pm.
+ # This is a problem because some systems silently truncate the file
+ # names while others treat long file names as an error.
+
+ my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
+
+ my(@subnames, $subname, %proto, %package);
+ my @cache = ();
+ my $caching = 1;
+ $last_package = '';
+ my $out;
+ while (<$in>) {
+ $fnr++;
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/);
+ # the following (tempting) old coding gives big troubles if a
+ # cut is forgotten at EOF:
+ # next if /^=\w/ .. /^=cut/;
+ if (/^package\s+([\w:]+)\s*;/) {
+ $this_package = $def_package = $1;
+ }
+
+ if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
+ print $out "# end of $last_package\::$subname\n1;\n"
+ if $last_package;
+ $subname = $1;
+ my $proto = $2 || '';
+ if ($subname =~ s/(.*):://){
+ $this_package = $1;
+ } else {
+ $this_package = $def_package;
+ }
+ my $fq_subname = "$this_package\::$subname";
+ $package{$fq_subname} = $this_package;
+ $proto{$fq_subname} = $proto;
+ push(@subnames, $fq_subname);
+ my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
+ $modpname = _modpname($this_package);
+ my($modnamedir) = catdir($autodir, $modpname);
+ mkpath($modnamedir,0,0777);
+ my($lpath) = catfile($modnamedir, "$lname.al");
+ my($spath) = catfile($modnamedir, "$sname.al");
+ my $path;
+
+ if (!$Is83 and open($out, ">$lpath")){
+ $path=$lpath;
+ print " writing $lpath\n" if ($Verbose>=2);
+ } else {
+ open($out, ">$spath") or die "Can't create $spath: $!\n";
+ $path=$spath;
+ print " writing $spath (with truncated name)\n"
+ if ($Verbose>=1);
+ }
+ push(@outfiles, $path);
+ my $lineno = $fnr - @cache;
+ print $out <<EOT;
+# NOTE: Derived from $filename.
+# Changes made here will be lost when autosplit is run again.
+# See AutoSplit.pm.
+package $this_package;
+
+#line $lineno "$filename (autosplit into $path)"
+EOT
+ print $out @cache;
+ @cache = ();
+ $caching = 0;
+ }
+ if($caching) {
+ push(@cache, $_) if @cache || /\S/;
+ } else {
+ print $out $_;
+ }
+ if(/^\}/) {
+ if($caching) {
+ print $out @cache;
+ @cache = ();
+ }
+ print $out "\n";
+ $caching = 1;
+ }
+ $last_package = $this_package if defined $this_package;
+ }
+ if ($subname) {
+ print $out @cache,"1;\n# end of $last_package\::$subname\n";
+ close($out);
+ }
+ close($in);
+
+ if (!$keep){ # don't keep any obsolete *.al files in the directory
+ my(%outfiles);
+ # @outfiles{@outfiles} = @outfiles;
+ # perl downcases all filenames on VMS (which upcases all filenames) so
+ # we'd better downcase the sub name list too, or subs with upper case
+ # letters in them will get their .al files deleted right after they're
+ # created. (The mixed case sub name won't match the all-lowercase
+ # filename, and so be cleaned up as a scrap file)
+ if ($Is_VMS or $Is83) {
+ %outfiles = map {lc($_) => lc($_) } @outfiles;
+ } else {
+ @outfiles{@outfiles} = @outfiles;
+ }
+ my(%outdirs,@outdirs);
+ for (@outfiles) {
+ $outdirs{File::Basename::dirname($_)}||=1;
+ }
+ for my $dir (keys %outdirs) {
+ opendir(my $outdir,$dir);
+ foreach (sort readdir($outdir)){
+ next unless /\.al\z/;
+ my($file) = catfile($dir, $_);
+ $file = lc $file if $Is83 or $Is_VMS;
+ next if $outfiles{$file};
+ print " deleting $file\n" if ($Verbose>=2);
+ my($deleted,$thistime); # catch all versions on VMS
+ do { $deleted += ($thistime = unlink $file) } while ($thistime);
+ carp ("Unable to delete $file: $!") unless $deleted;
+ }
+ closedir($outdir);
+ }
+ }
+
+ open(my $ts,">$al_idx_file") or
+ carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
+ print $ts "# Index created by AutoSplit for $filename\n";
+ print $ts "# (file acts as timestamp)\n";
+ $last_package = '';
+ for my $fqs (@subnames) {
+ my($subname) = $fqs;
+ $subname =~ s/.*:://;
+ print $ts "package $package{$fqs};\n"
+ unless $last_package eq $package{$fqs};
+ print $ts "sub $subname $proto{$fqs};\n";
+ $last_package = $package{$fqs};
+ }
+ print $ts "1;\n";
+ close($ts);
+
+ _check_unique($filename, $Maxlen, 1, @outfiles);
+
+ @outfiles;
+}
+
+sub _modpname ($) {
+ my($package) = @_;
+ my $modpname = $package;
+ if ($^O eq 'MSWin32') {
+ $modpname =~ s#::#\\#g;
+ } else {
+ my @modpnames = ();
+ while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
+ push @modpnames, $1;
+ $modpname = $2;
+ }
+ $modpname = catfile(@modpnames, $modpname);
+ }
+ if ($Is_VMS) {
+ $modpname = VMS::Filespec::unixify($modpname); # may have dirs
+ }
+ $modpname;
+}
+
+sub _check_unique {
+ my($filename, $maxlen, $warn, @outfiles) = @_;
+ my(%notuniq) = ();
+ my(%shorts) = ();
+ my(@toolong) = grep(
+ length(File::Basename::basename($_))
+ > $maxlen,
+ @outfiles
+ );
+
+ foreach (@toolong){
+ my($dir) = File::Basename::dirname($_);
+ my($file) = File::Basename::basename($_);
+ my($trunc) = substr($file,0,$maxlen);
+ $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
+ $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
+ "$shorts{$dir}{$trunc}, $file" : $file;
+ }
+ if (%notuniq && $warn){
+ print "$filename: some names are not unique when " .
+ "truncated to $maxlen characters:\n";
+ foreach my $dir (sort keys %notuniq){
+ print " directory $dir:\n";
+ foreach my $trunc (sort keys %{$notuniq{$dir}}) {
+ print " $shorts{$dir}{$trunc} truncate to $trunc\n";
+ }
+ }
+ }
+}
+
+1;
+__END__
+
+# test functions so AutoSplit.pm can be applied to itself:
+sub test1 ($) { "test 1\n"; }
+sub test2 ($$) { "test 2\n"; }
+sub test3 ($$$) { "test 3\n"; }
+sub testtesttesttest4_1 { "test 4\n"; }
+sub testtesttesttest4_2 { "duplicate test 4\n"; }
+sub Just::Another::test5 { "another test 5\n"; }
+sub test6 { return join ":", __FILE__,__LINE__; }
+package Yet::Another::AutoSplit;
+sub testtesttesttest4_1 ($) { "another test 4\n"; }
+sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
+package Yet::More::Attributes;
+sub test_a1 ($) : locked :locked { 1; }
+sub test_a2 : locked { 1; }
diff --git a/Master/tlpkg/tlperl/lib/B.pm b/Master/tlpkg/tlperl/lib/B.pm
new file mode 100644
index 00000000000..f7d22f11478
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B.pm
@@ -0,0 +1,1189 @@
+# B.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B;
+
+our $VERSION = '1.23';
+
+use XSLoader ();
+require Exporter;
+@ISA = qw(Exporter);
+
+# walkoptree_slow comes from B.pm (you are there),
+# walkoptree comes from B.xs
+@EXPORT_OK = qw(minus_c ppname save_BEGINs
+ class peekop cast_I32 cstring cchar hash threadsv_names
+ main_root main_start main_cv svref_2object opnumber
+ sub_generation amagic_generation perlstring
+ walkoptree_slow walkoptree walkoptree_exec walksymtable
+ parents comppadlist sv_undef compile_stats timing_info
+ begin_av init_av check_av end_av regex_padav dowarn defstash
+ curstash warnhook diehook inc_gv @optype @specialsv_name
+ );
+push @EXPORT_OK, qw(unitcheck_av) if $] > 5.009;
+
+sub OPf_KIDS ();
+use strict;
+@B::SV::ISA = 'B::OBJECT';
+@B::NULL::ISA = 'B::SV';
+@B::PV::ISA = 'B::SV';
+@B::IV::ISA = 'B::SV';
+@B::NV::ISA = 'B::SV';
+# RV is eliminated with 5.11.0, but effectively is a specialisation of IV now.
+@B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV';
+@B::PVIV::ISA = qw(B::PV B::IV);
+@B::PVNV::ISA = qw(B::PVIV B::NV);
+@B::PVMG::ISA = 'B::PVNV';
+@B::REGEXP::ISA = 'B::PVMG' if $] >= 5.011;
+# Change in the inheritance hierarchy post 5.9.0
+@B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
+# BM is eliminated post 5.9.5, but effectively is a specialisation of GV now.
+@B::BM::ISA = $] > 5.009005 ? 'B::GV' : 'B::PVMG';
+@B::AV::ISA = 'B::PVMG';
+@B::GV::ISA = 'B::PVMG';
+@B::HV::ISA = 'B::PVMG';
+@B::CV::ISA = 'B::PVMG';
+@B::IO::ISA = 'B::PVMG';
+@B::FM::ISA = 'B::CV';
+
+@B::OP::ISA = 'B::OBJECT';
+@B::UNOP::ISA = 'B::OP';
+@B::BINOP::ISA = 'B::UNOP';
+@B::LOGOP::ISA = 'B::UNOP';
+@B::LISTOP::ISA = 'B::BINOP';
+@B::SVOP::ISA = 'B::OP';
+@B::PADOP::ISA = 'B::OP';
+@B::PVOP::ISA = 'B::OP';
+@B::LOOP::ISA = 'B::LISTOP';
+@B::PMOP::ISA = 'B::LISTOP';
+@B::COP::ISA = 'B::OP';
+
+@B::SPECIAL::ISA = 'B::OBJECT';
+
+@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
+# bytecode.pl contained the following comment:
+# Nullsv *must* come first in the following so that the condition
+# ($$sv == 0) can continue to be used to test (sv == Nullsv).
+@B::specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no
+ (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD);
+
+{
+ # Stop "-w" from complaining about the lack of a real B::OBJECT class
+ package B::OBJECT;
+}
+
+sub B::GV::SAFENAME {
+ my $name = (shift())->NAME;
+
+ # The regex below corresponds to the isCONTROLVAR macro
+ # from toke.c
+
+ $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
+ chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
+
+ # When we say unicode_to_native we really mean ascii_to_native,
+ # which matters iff this is a non-ASCII platform (EBCDIC).
+
+ return $name;
+}
+
+sub B::IV::int_value {
+ my ($self) = @_;
+ return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
+}
+
+sub B::NULL::as_string() {""}
+sub B::IV::as_string() {goto &B::IV::int_value}
+sub B::PV::as_string() {goto &B::PV::PV}
+
+my $debug;
+my $op_count = 0;
+my @parents = ();
+
+sub debug {
+ my ($class, $value) = @_;
+ $debug = $value;
+ walkoptree_debug($value);
+}
+
+sub class {
+ my $obj = shift;
+ my $name = ref $obj;
+ $name =~ s/^.*:://;
+ return $name;
+}
+
+sub parents { \@parents }
+
+# For debugging
+sub peekop {
+ my $op = shift;
+ return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
+}
+
+sub walkoptree_slow {
+ my($op, $method, $level) = @_;
+ $op_count++; # just for statistics
+ $level ||= 0;
+ warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
+ $op->$method($level) if $op->can($method);
+ if ($$op && ($op->flags & OPf_KIDS)) {
+ my $kid;
+ unshift(@parents, $op);
+ for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walkoptree_slow($kid, $method, $level + 1);
+ }
+ shift @parents;
+ }
+ if (class($op) eq 'PMOP'
+ && ref($op->pmreplroot)
+ && ${$op->pmreplroot}
+ && $op->pmreplroot->isa( 'B::OP' ))
+ {
+ unshift(@parents, $op);
+ walkoptree_slow($op->pmreplroot, $method, $level + 1);
+ shift @parents;
+ }
+}
+
+sub compile_stats {
+ return "Total number of OPs processed: $op_count\n";
+}
+
+sub timing_info {
+ my ($sec, $min, $hr) = localtime;
+ my ($user, $sys) = times;
+ sprintf("%02d:%02d:%02d user=$user sys=$sys",
+ $hr, $min, $sec, $user, $sys);
+}
+
+my %symtable;
+
+sub clearsym {
+ %symtable = ();
+}
+
+sub savesym {
+ my ($obj, $value) = @_;
+# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", $$obj)};
+}
+
+sub walkoptree_exec {
+ my ($op, $method, $level) = @_;
+ $level ||= 0;
+ my ($sym, $ppname);
+ my $prefix = " " x $level;
+ for (; $$op; $op = $op->next) {
+ $sym = objsym($op);
+ if (defined($sym)) {
+ print $prefix, "goto $sym\n";
+ return;
+ }
+ savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
+ $op->$method($level);
+ $ppname = $op->name;
+ if ($ppname =~
+ /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/)
+ {
+ print $prefix, uc($1), " => {\n";
+ walkoptree_exec($op->other, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "match" || $ppname eq "subst") {
+ my $pmreplstart = $op->pmreplstart;
+ if ($$pmreplstart) {
+ print $prefix, "PMREPLSTART => {\n";
+ walkoptree_exec($pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ } elsif ($ppname eq "substcont") {
+ print $prefix, "SUBSTCONT => {\n";
+ walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->other;
+ } elsif ($ppname eq "enterloop") {
+ print $prefix, "REDO => {\n";
+ walkoptree_exec($op->redoop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "NEXT => {\n";
+ walkoptree_exec($op->nextop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "LAST => {\n";
+ walkoptree_exec($op->lastop, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "subst") {
+ my $replstart = $op->pmreplstart;
+ if ($$replstart) {
+ print $prefix, "SUBST => {\n";
+ walkoptree_exec($replstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ }
+ }
+}
+
+sub walksymtable {
+ my ($symref, $method, $recurse, $prefix) = @_;
+ my $sym;
+ my $ref;
+ my $fullname;
+ no strict 'refs';
+ $prefix = '' unless defined $prefix;
+ while (($sym, $ref) = each %$symref) {
+ $fullname = "*main::".$prefix.$sym;
+ if ($sym =~ /::$/) {
+ $sym = $prefix . $sym;
+ if (svref_2object(\*$sym)->NAME ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
+ walksymtable(\%$fullname, $method, $recurse, $sym);
+ }
+ } else {
+ svref_2object(\*$fullname)->$method();
+ }
+ }
+}
+
+{
+ package B::Section;
+ my $output_fh;
+ my %sections;
+
+ sub new {
+ my ($class, $section, $symtable, $default) = @_;
+ $output_fh ||= FileHandle->new_tmpfile;
+ my $obj = bless [-1, $section, $symtable, $default], $class;
+ $sections{$section} = $obj;
+ return $obj;
+ }
+
+ sub get {
+ my ($class, $section) = @_;
+ return $sections{$section};
+ }
+
+ sub add {
+ my $section = shift;
+ while (defined($_ = shift)) {
+ print $output_fh "$section->[1]\t$_\n";
+ $section->[0]++;
+ }
+ }
+
+ sub index {
+ my $section = shift;
+ return $section->[0];
+ }
+
+ sub name {
+ my $section = shift;
+ return $section->[1];
+ }
+
+ sub symtable {
+ my $section = shift;
+ return $section->[2];
+ }
+
+ sub default {
+ my $section = shift;
+ return $section->[3];
+ }
+
+ sub output {
+ my ($section, $fh, $format) = @_;
+ my $name = $section->name;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+
+ seek($output_fh, 0, 0);
+ while (<$output_fh>) {
+ chomp;
+ s/^(.*?)\t//;
+ if ($1 eq $name) {
+ s{(s\\_[0-9a-f]+)} {
+ exists($sym->{$1}) ? $sym->{$1} : $default;
+ }ge;
+ printf $fh $format, $_;
+ }
+ }
+ }
+}
+
+XSLoader::load 'B';
+
+1;
+
+__END__
+
+=head1 NAME
+
+B - The Perl Compiler Backend
+
+=head1 SYNOPSIS
+
+ use B;
+
+=head1 DESCRIPTION
+
+The C<B> module supplies classes which allow a Perl program to delve
+into its own innards. It is the module used to implement the
+"backends" of the Perl compiler. Usage of the compiler does not
+require knowledge of this module: see the F<O> module for the
+user-visible part. The C<B> module is of use to those who want to
+write new compiler backends. This documentation assumes that the
+reader knows a fair amount about perl's internals including such
+things as SVs, OPs and the internal symbol table and syntax tree
+of a program.
+
+=head1 OVERVIEW
+
+The C<B> module contains a set of utility functions for querying the
+current state of the Perl interpreter; typically these functions
+return objects from the B::SV and B::OP classes, or their derived
+classes. These classes in turn define methods for querying the
+resulting objects about their own internal state.
+
+=head1 Utility Functions
+
+The C<B> module exports a variety of functions: some are simple
+utility functions, others provide a Perl program with a way to
+get an initial "handle" on an internal object.
+
+=head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects
+
+For descriptions of the class hierarchy of these objects and the
+methods that can be called on them, see below, L<"OVERVIEW OF
+CLASSES"> and L<"SV-RELATED CLASSES">.
+
+=over 4
+
+=item sv_undef
+
+Returns the SV object corresponding to the C variable C<sv_undef>.
+
+=item sv_yes
+
+Returns the SV object corresponding to the C variable C<sv_yes>.
+
+=item sv_no
+
+Returns the SV object corresponding to the C variable C<sv_no>.
+
+=item svref_2object(SVREF)
+
+Takes a reference to any Perl value, and turns the referred-to value
+into an object in the appropriate B::OP-derived or B::SV-derived
+class. Apart from functions such as C<main_root>, this is the primary
+way to get an initial "handle" on an internal perl data structure
+which can then be followed with the other access methods.
+
+The returned object will only be valid as long as the underlying OPs
+and SVs continue to exist. Do not attempt to use the object after the
+underlying structures are freed.
+
+=item amagic_generation
+
+Returns the SV object corresponding to the C variable C<amagic_generation>.
+
+=item init_av
+
+Returns the AV object (i.e. in class B::AV) representing INIT blocks.
+
+=item check_av
+
+Returns the AV object (i.e. in class B::AV) representing CHECK blocks.
+
+=item unitcheck_av
+
+Returns the AV object (i.e. in class B::AV) representing UNITCHECK blocks.
+
+=item begin_av
+
+Returns the AV object (i.e. in class B::AV) representing BEGIN blocks.
+
+=item end_av
+
+Returns the AV object (i.e. in class B::AV) representing END blocks.
+
+=item comppadlist
+
+Returns the AV object (i.e. in class B::AV) of the global comppadlist.
+
+=item regex_padav
+
+Only when perl was compiled with ithreads.
+
+=item main_cv
+
+Return the (faked) CV corresponding to the main part of the Perl
+program.
+
+=back
+
+=head2 Functions for Examining the Symbol Table
+
+=over 4
+
+=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)
+
+Walk the symbol table starting at SYMREF and call METHOD on each
+symbol (a B::GV object) visited. When the walk reaches package
+symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
+name, and only recurses into the package if that sub returns true.
+
+PREFIX is the name of the SYMREF you're walking.
+
+For example:
+
+ # Walk CGI's symbol table calling print_subs on each symbol.
+ # Recurse only into CGI::Util::
+ walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
+ 'CGI::');
+
+print_subs() is a B::GV method you have declared. Also see L<"B::GV
+Methods">, below.
+
+=back
+
+=head2 Functions Returning C<B::OP> objects or for walking op trees
+
+For descriptions of the class hierarchy of these objects and the
+methods that can be called on them, see below, L<"OVERVIEW OF
+CLASSES"> and L<"OP-RELATED CLASSES">.
+
+=over 4
+
+=item main_root
+
+Returns the root op (i.e. an object in the appropriate B::OP-derived
+class) of the main part of the Perl program.
+
+=item main_start
+
+Returns the starting op of the main part of the Perl program.
+
+=item walkoptree(OP, METHOD)
+
+Does a tree-walk of the syntax tree based at OP and calls METHOD on
+each op it visits. Each node is visited before its children. If
+C<walkoptree_debug> (see below) has been called to turn debugging on then
+the method C<walkoptree_debug> is called on each op before METHOD is
+called.
+
+=item walkoptree_debug(DEBUG)
+
+Returns the current debugging flag for C<walkoptree>. If the optional
+DEBUG argument is non-zero, it sets the debugging flag to that. See
+the description of C<walkoptree> above for what the debugging flag
+does.
+
+=back
+
+=head2 Miscellaneous Utility Functions
+
+=over 4
+
+=item ppname(OPNUM)
+
+Return the PP function name (e.g. "pp_add") of op number OPNUM.
+
+=item hash(STR)
+
+Returns a string in the form "0x..." representing the value of the
+internal hash function used by perl on string STR.
+
+=item cast_I32(I)
+
+Casts I to the internal I32 type used by that perl.
+
+=item minus_c
+
+Does the equivalent of the C<-c> command-line option. Obviously, this
+is only useful in a BEGIN block or else the flag is set too late.
+
+=item cstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in C source code.
+
+=item perlstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in Perl source code.
+
+=item class(OBJ)
+
+Returns the class of an object without the part of the classname
+preceding the first C<"::">. This is used to turn C<"B::UNOP"> into
+C<"UNOP"> for example.
+
+=item threadsv_names
+
+In a perl compiled for threads, this returns a list of the special
+per-thread threadsv variables.
+
+=back
+
+=head2 Exported utility variabiles
+
+=over 4
+
+=item @optype
+
+ my $op_type = $optype[$op_type_num];
+
+A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
+
+=item @specialsv_name
+
+ my $sv_name = $specialsv_name[$sv_index];
+
+Certain SV types are considered 'special'. They're represented by
+B::SPECIAL and are referred to by a number from the specialsv_list.
+This array maps that number back to the name of the SV (like 'Nullsv'
+or '&PL_sv_undef').
+
+=back
+
+
+=head1 OVERVIEW OF CLASSES
+
+The C structures used by Perl's internals to hold SV and OP
+information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
+class hierarchy and the C<B> module gives access to them via a true
+object hierarchy. Structure fields which point to other objects
+(whether types of SV or types of OP) are represented by the C<B>
+module as Perl objects of the appropriate class.
+
+The bulk of the C<B> module is the methods for accessing fields of
+these structures.
+
+Note that all access is read-only. You cannot modify the internals by
+using this module. Also, note that the B::OP and B::SV objects created
+by this module are only valid for as long as the underlying objects
+exist; their creation doesn't increase the reference counts of the
+underlying objects. Trying to access the fields of a freed object will
+give incomprehensible results, or worse.
+
+=head2 SV-RELATED CLASSES
+
+B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM (5.9.5 and
+earlier), B::PVLV, B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes
+correspond in the obvious way to the underlying C structures of similar names.
+The inheritance hierarchy mimics the underlying C "inheritance". For the
+5.10.x branch, (I<ie> 5.10.0, 5.10.1 I<etc>) this is:
+
+ B::SV
+ |
+ +------------+------------+------------+
+ | | | |
+ B::PV B::IV B::NV B::RV
+ \ / /
+ \ / /
+ B::PVIV /
+ \ /
+ \ /
+ \ /
+ B::PVNV
+ |
+ |
+ B::PVMG
+ |
+ +-----+-----+-----+-----+
+ | | | | |
+ B::AV B::GV B::HV B::CV B::IO
+ | |
+ | |
+ B::PVLV B::FM
+
+For 5.9.0 and earlier, PVLV is a direct subclass of PVMG, and BM is still
+present as a distinct type, so the base of this diagram is
+
+
+ |
+ |
+ B::PVMG
+ |
+ +------+-----+-----+-----+-----+-----+
+ | | | | | | |
+ B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO
+ |
+ |
+ B::FM
+
+For 5.11.0 and later, B::RV is abolished, and IVs can be used to store
+references, and a new type B::REGEXP is introduced, giving this structure:
+
+ B::SV
+ |
+ +------------+------------+
+ | | |
+ B::PV B::IV B::NV
+ \ / /
+ \ / /
+ B::PVIV /
+ \ /
+ \ /
+ \ /
+ B::PVNV
+ |
+ |
+ B::PVMG
+ |
+ +-------+-------+---+---+-------+-------+
+ | | | | | |
+ B::AV B::GV B::HV B::CV B::IO B::REGEXP
+ | |
+ | |
+ B::PVLV B::FM
+
+
+Access methods correspond to the underlying C macros for field access,
+usually with the leading "class indication" prefix removed (Sv, Av,
+Hv, ...). The leading prefix is only left in cases where its removal
+would cause a clash in method name. For example, C<GvREFCNT> stays
+as-is since its abbreviation would clash with the "superclass" method
+C<REFCNT> (corresponding to the C function C<SvREFCNT>).
+
+=head2 B::SV Methods
+
+=over 4
+
+=item REFCNT
+
+=item FLAGS
+
+=item object_2svref
+
+Returns a reference to the regular scalar corresponding to this
+B::SV object. In other words, this method is the inverse operation
+to the svref_2object() subroutine. This scalar and other data it points
+at should be considered read-only: modifying them is neither safe nor
+guaranteed to have a sensible effect.
+
+=back
+
+=head2 B::IV Methods
+
+=over 4
+
+=item IV
+
+Returns the value of the IV, I<interpreted as
+a signed integer>. This will be misleading
+if C<FLAGS & SVf_IVisUV>. Perhaps you want the
+C<int_value> method instead?
+
+=item IVX
+
+=item UVX
+
+=item int_value
+
+This method returns the value of the IV as an integer.
+It differs from C<IV> in that it returns the correct
+value regardless of whether it's stored signed or
+unsigned.
+
+=item needs64bits
+
+=item packiv
+
+=back
+
+=head2 B::NV Methods
+
+=over 4
+
+=item NV
+
+=item NVX
+
+=back
+
+=head2 B::RV Methods
+
+=over 4
+
+=item RV
+
+=back
+
+=head2 B::PV Methods
+
+=over 4
+
+=item PV
+
+This method is the one you usually want. It constructs a
+string using the length and offset information in the struct:
+for ordinary scalars it will return the string that you'd see
+from Perl, even if it contains null characters.
+
+=item RV
+
+Same as B::RV::RV, except that it will die() if the PV isn't
+a reference.
+
+=item PVX
+
+This method is less often useful. It assumes that the string
+stored in the struct is null-terminated, and disregards the
+length information.
+
+It is the appropriate method to use if you need to get the name
+of a lexical variable from a padname array. Lexical variable names
+are always stored with a null terminator, and the length field
+(SvCUR) is overloaded for other purposes and can't be relied on here.
+
+=back
+
+=head2 B::PVMG Methods
+
+=over 4
+
+=item MAGIC
+
+=item SvSTASH
+
+=back
+
+=head2 B::MAGIC Methods
+
+=over 4
+
+=item MOREMAGIC
+
+=item precomp
+
+Only valid on r-magic, returns the string that generated the regexp.
+
+=item PRIVATE
+
+=item TYPE
+
+=item FLAGS
+
+=item OBJ
+
+Will die() if called on r-magic.
+
+=item PTR
+
+=item REGEX
+
+Only valid on r-magic, returns the integer value of the REGEX stored
+in the MAGIC.
+
+=back
+
+=head2 B::PVLV Methods
+
+=over 4
+
+=item TARGOFF
+
+=item TARGLEN
+
+=item TYPE
+
+=item TARG
+
+=back
+
+=head2 B::BM Methods
+
+=over 4
+
+=item USEFUL
+
+=item PREVIOUS
+
+=item RARE
+
+=item TABLE
+
+=back
+
+=head2 B::GV Methods
+
+=over 4
+
+=item is_empty
+
+This method returns TRUE if the GP field of the GV is NULL.
+
+=item NAME
+
+=item SAFENAME
+
+This method returns the name of the glob, but if the first
+character of the name is a control character, then it converts
+it to ^X first, so that *^G would return "^G" rather than "\cG".
+
+It's useful if you want to print out the name of a variable.
+If you restrict yourself to globs which exist at compile-time
+then the result ought to be unambiguous, because code like
+C<${"^G"} = 1> is compiled as two ops - a constant string and
+a dereference (rv2gv) - so that the glob is created at runtime.
+
+If you're working with globs at runtime, and need to disambiguate
+*^G from *{"^G"}, then you should use the raw NAME method.
+
+=item STASH
+
+=item SV
+
+=item IO
+
+=item FORM
+
+=item AV
+
+=item HV
+
+=item EGV
+
+=item CV
+
+=item CVGEN
+
+=item LINE
+
+=item FILE
+
+=item FILEGV
+
+=item GvREFCNT
+
+=item FLAGS
+
+=back
+
+=head2 B::IO Methods
+
+=over 4
+
+=item LINES
+
+=item PAGE
+
+=item PAGE_LEN
+
+=item LINES_LEFT
+
+=item TOP_NAME
+
+=item TOP_GV
+
+=item FMT_NAME
+
+=item FMT_GV
+
+=item BOTTOM_NAME
+
+=item BOTTOM_GV
+
+=item SUBPROCESS
+
+=item IoTYPE
+
+=item IoFLAGS
+
+=item IsSTD
+
+Takes one arguments ( 'stdin' | 'stdout' | 'stderr' ) and returns true
+if the IoIFP of the object is equal to the handle whose name was
+passed as argument ( i.e. $io->IsSTD('stderr') is true if
+IoIFP($io) == PerlIO_stdin() ).
+
+=back
+
+=head2 B::AV Methods
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item ARRAY
+
+=item ARRAYelt
+
+Like C<ARRAY>, but takes an index as an argument to get only one element,
+rather than a list of all of them.
+
+=item OFF
+
+This method is deprecated if running under Perl 5.8, and is no longer present
+if running under Perl 5.9
+
+=item AvFLAGS
+
+This method returns the AV specific flags. In Perl 5.9 these are now stored
+in with the main SV flags, so this method is no longer present.
+
+=back
+
+=head2 B::CV Methods
+
+=over 4
+
+=item STASH
+
+=item START
+
+=item ROOT
+
+=item GV
+
+=item FILE
+
+=item DEPTH
+
+=item PADLIST
+
+=item OUTSIDE
+
+=item OUTSIDE_SEQ
+
+=item XSUB
+
+=item XSUBANY
+
+For constant subroutines, returns the constant SV returned by the subroutine.
+
+=item CvFLAGS
+
+=item const_sv
+
+=back
+
+=head2 B::HV Methods
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item KEYS
+
+=item RITER
+
+=item NAME
+
+=item ARRAY
+
+=item PMROOT
+
+This method is not present if running under Perl 5.9, as the PMROOT
+information is no longer stored directly in the hash.
+
+=back
+
+=head2 OP-RELATED CLASSES
+
+C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>,
+C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>.
+
+These classes correspond in the obvious way to the underlying C
+structures of similar names. The inheritance hierarchy mimics the
+underlying C "inheritance":
+
+ B::OP
+ |
+ +---------------+--------+--------+-------+
+ | | | | |
+ B::UNOP B::SVOP B::PADOP B::COP B::PVOP
+ ,' `-.
+ / `--.
+ B::BINOP B::LOGOP
+ |
+ |
+ B::LISTOP
+ ,' `.
+ / \
+ B::LOOP B::PMOP
+
+Access methods correspond to the underlying C structre field names,
+with the leading "class indication" prefix (C<"op_">) removed.
+
+=head2 B::OP Methods
+
+These methods get the values of similarly named fields within the OP
+data structure. See top of C<op.h> for more info.
+
+=over 4
+
+=item next
+
+=item sibling
+
+=item name
+
+This returns the op name as a string (e.g. "add", "rv2av").
+
+=item ppaddr
+
+This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
+"PL_ppaddr[OP_RV2AV]").
+
+=item desc
+
+This returns the op description from the global C PL_op_desc array
+(e.g. "addition" "array deref").
+
+=item targ
+
+=item type
+
+=item opt
+
+=item flags
+
+=item private
+
+=item spare
+
+=back
+
+=head2 B::UNOP METHOD
+
+=over 4
+
+=item first
+
+=back
+
+=head2 B::BINOP METHOD
+
+=over 4
+
+=item last
+
+=back
+
+=head2 B::LOGOP METHOD
+
+=over 4
+
+=item other
+
+=back
+
+=head2 B::LISTOP METHOD
+
+=over 4
+
+=item children
+
+=back
+
+=head2 B::PMOP Methods
+
+=over 4
+
+=item pmreplroot
+
+=item pmreplstart
+
+=item pmnext
+
+Only up to Perl 5.9.4
+
+=item pmregexp
+
+=item pmflags
+
+=item extflags
+
+Since Perl 5.9.5
+
+=item precomp
+
+=item pmoffset
+
+Only when perl was compiled with ithreads.
+
+=back
+
+=head2 B::SVOP METHOD
+
+=over 4
+
+=item sv
+
+=item gv
+
+=back
+
+=head2 B::PADOP METHOD
+
+=over 4
+
+=item padix
+
+=back
+
+=head2 B::PVOP METHOD
+
+=over 4
+
+=item pv
+
+=back
+
+=head2 B::LOOP Methods
+
+=over 4
+
+=item redoop
+
+=item nextop
+
+=item lastop
+
+=back
+
+=head2 B::COP Methods
+
+=over 4
+
+=item label
+
+=item stash
+
+=item stashpv
+
+=item file
+
+=item cop_seq
+
+=item arybase
+
+=item line
+
+=item warnings
+
+=item io
+
+=item hints
+
+=item hints_hash
+
+=back
+
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Benchmark.pm b/Master/tlpkg/tlperl/lib/Benchmark.pm
new file mode 100644
index 00000000000..269674cfda5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Benchmark.pm
@@ -0,0 +1,1044 @@
+package Benchmark;
+
+use strict;
+
+
+=head1 NAME
+
+Benchmark - benchmark running times of Perl code
+
+=head1 SYNOPSIS
+
+ use Benchmark qw(:all) ;
+
+ timethis ($count, "code");
+
+ # Use Perl code in strings...
+ timethese($count, {
+ 'Name1' => '...code1...',
+ 'Name2' => '...code2...',
+ });
+
+ # ... or use subroutine references.
+ timethese($count, {
+ 'Name1' => sub { ...code1... },
+ 'Name2' => sub { ...code2... },
+ });
+
+ # cmpthese can be used both ways as well
+ cmpthese($count, {
+ 'Name1' => '...code1...',
+ 'Name2' => '...code2...',
+ });
+
+ cmpthese($count, {
+ 'Name1' => sub { ...code1... },
+ 'Name2' => sub { ...code2... },
+ });
+
+ # ...or in two stages
+ $results = timethese($count,
+ {
+ 'Name1' => sub { ...code1... },
+ 'Name2' => sub { ...code2... },
+ },
+ 'none'
+ );
+ cmpthese( $results ) ;
+
+ $t = timeit($count, '...other code...')
+ print "$count loops of other code took:",timestr($t),"\n";
+
+ $t = countit($time, '...other code...')
+ $count = $t->iters ;
+ print "$count loops of other code took:",timestr($t),"\n";
+
+ # enable hires wallclock timing if possible
+ use Benchmark ':hireswallclock';
+
+=head1 DESCRIPTION
+
+The Benchmark module encapsulates a number of routines to help you
+figure out how long it takes to execute some code.
+
+timethis - run a chunk of code several times
+
+timethese - run several chunks of code several times
+
+cmpthese - print results of timethese as a comparison chart
+
+timeit - run a chunk of code and see how long it goes
+
+countit - see how many times a chunk of code runs in a given time
+
+
+=head2 Methods
+
+=over 10
+
+=item new
+
+Returns the current time. Example:
+
+ use Benchmark;
+ $t0 = Benchmark->new;
+ # ... your code here ...
+ $t1 = Benchmark->new;
+ $td = timediff($t1, $t0);
+ print "the code took:",timestr($td),"\n";
+
+=item debug
+
+Enables or disable debugging by setting the C<$Benchmark::Debug> flag:
+
+ Benchmark->debug(1);
+ $t = timeit(10, ' 5 ** $Global ');
+ Benchmark->debug(0);
+
+=item iters
+
+Returns the number of iterations.
+
+=back
+
+=head2 Standard Exports
+
+The following routines will be exported into your namespace
+if you use the Benchmark module:
+
+=over 10
+
+=item timeit(COUNT, CODE)
+
+Arguments: COUNT is the number of times to run the loop, and CODE is
+the code to run. CODE may be either a code reference or a string to
+be eval'd; either way it will be run in the caller's package.
+
+Returns: a Benchmark object.
+
+=item timethis ( COUNT, CODE, [ TITLE, [ STYLE ]] )
+
+Time COUNT iterations of CODE. CODE may be a string to eval or a
+code reference; either way the CODE will run in the caller's package.
+Results will be printed to STDOUT as TITLE followed by the times.
+TITLE defaults to "timethis COUNT" if none is provided. STYLE
+determines the format of the output, as described for timestr() below.
+
+The COUNT can be zero or negative: this means the I<minimum number of
+CPU seconds> to run. A zero signifies the default of 3 seconds. For
+example to run at least for 10 seconds:
+
+ timethis(-10, $code)
+
+or to run two pieces of code tests for at least 3 seconds:
+
+ timethese(0, { test1 => '...', test2 => '...'})
+
+CPU seconds is, in UNIX terms, the user time plus the system time of
+the process itself, as opposed to the real (wallclock) time and the
+time spent by the child processes. Less than 0.1 seconds is not
+accepted (-0.01 as the count, for example, will cause a fatal runtime
+exception).
+
+Note that the CPU seconds is the B<minimum> time: CPU scheduling and
+other operating system factors may complicate the attempt so that a
+little bit more time is spent. The benchmark output will, however,
+also tell the number of C<$code> runs/second, which should be a more
+interesting number than the actually spent seconds.
+
+Returns a Benchmark object.
+
+=item timethese ( COUNT, CODEHASHREF, [ STYLE ] )
+
+The CODEHASHREF is a reference to a hash containing names as keys
+and either a string to eval or a code reference for each value.
+For each (KEY, VALUE) pair in the CODEHASHREF, this routine will
+call
+
+ timethis(COUNT, VALUE, KEY, STYLE)
+
+The routines are called in string comparison order of KEY.
+
+The COUNT can be zero or negative, see timethis().
+
+Returns a hash reference of Benchmark objects, keyed by name.
+
+=item timediff ( T1, T2 )
+
+Returns the difference between two Benchmark times as a Benchmark
+object suitable for passing to timestr().
+
+=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] )
+
+Returns a string that formats the times in the TIMEDIFF object in
+the requested STYLE. TIMEDIFF is expected to be a Benchmark object
+similar to that returned by timediff().
+
+STYLE can be any of 'all', 'none', 'noc', 'nop' or 'auto'. 'all' shows
+each of the 5 times available ('wallclock' time, user time, system time,
+user time of children, and system time of children). 'noc' shows all
+except the two children times. 'nop' shows only wallclock and the
+two children times. 'auto' (the default) will act as 'all' unless
+the children times are both zero, in which case it acts as 'noc'.
+'none' prevents output.
+
+FORMAT is the L<printf(3)>-style format specifier (without the
+leading '%') to use to print the times. It defaults to '5.2f'.
+
+=back
+
+=head2 Optional Exports
+
+The following routines will be exported into your namespace
+if you specifically ask that they be imported:
+
+=over 10
+
+=item clearcache ( COUNT )
+
+Clear the cached time for COUNT rounds of the null loop.
+
+=item clearallcache ( )
+
+Clear all cached times.
+
+=item cmpthese ( COUNT, CODEHASHREF, [ STYLE ] )
+
+=item cmpthese ( RESULTSHASHREF, [ STYLE ] )
+
+Optionally calls timethese(), then outputs comparison chart. This:
+
+ cmpthese( -1, { a => "++\$i", b => "\$i *= 2" } ) ;
+
+outputs a chart like:
+
+ Rate b a
+ b 2831802/s -- -61%
+ a 7208959/s 155% --
+
+This chart is sorted from slowest to fastest, and shows the percent speed
+difference between each pair of tests.
+
+C<cmpthese> can also be passed the data structure that timethese() returns:
+
+ $results = timethese( -1, { a => "++\$i", b => "\$i *= 2" } ) ;
+ cmpthese( $results );
+
+in case you want to see both sets of results.
+If the first argument is an unblessed hash reference,
+that is RESULTSHASHREF; otherwise that is COUNT.
+
+Returns a reference to an ARRAY of rows, each row is an ARRAY of cells from the
+above chart, including labels. This:
+
+ my $rows = cmpthese( -1, { a => '++$i', b => '$i *= 2' }, "none" );
+
+returns a data structure like:
+
+ [
+ [ '', 'Rate', 'b', 'a' ],
+ [ 'b', '2885232/s', '--', '-59%' ],
+ [ 'a', '7099126/s', '146%', '--' ],
+ ]
+
+B<NOTE>: This result value differs from previous versions, which returned
+the C<timethese()> result structure. If you want that, just use the two
+statement C<timethese>...C<cmpthese> idiom shown above.
+
+Incidently, note the variance in the result values between the two examples;
+this is typical of benchmarking. If this were a real benchmark, you would
+probably want to run a lot more iterations.
+
+=item countit(TIME, CODE)
+
+Arguments: TIME is the minimum length of time to run CODE for, and CODE is
+the code to run. CODE may be either a code reference or a string to
+be eval'd; either way it will be run in the caller's package.
+
+TIME is I<not> negative. countit() will run the loop many times to
+calculate the speed of CODE before running it for TIME. The actual
+time run for will usually be greater than TIME due to system clock
+resolution, so it's best to look at the number of iterations divided
+by the times that you are concerned with, not just the iterations.
+
+Returns: a Benchmark object.
+
+=item disablecache ( )
+
+Disable caching of timings for the null loop. This will force Benchmark
+to recalculate these timings for each new piece of code timed.
+
+=item enablecache ( )
+
+Enable caching of timings for the null loop. The time taken for COUNT
+rounds of the null loop will be calculated only once for each
+different COUNT used.
+
+=item timesum ( T1, T2 )
+
+Returns the sum of two Benchmark times as a Benchmark object suitable
+for passing to timestr().
+
+=back
+
+=head2 :hireswallclock
+
+If the Time::HiRes module has been installed, you can specify the
+special tag C<:hireswallclock> for Benchmark (if Time::HiRes is not
+available, the tag will be silently ignored). This tag will cause the
+wallclock time to be measured in microseconds, instead of integer
+seconds. Note though that the speed computations are still conducted
+in CPU time, not wallclock time.
+
+=head1 NOTES
+
+The data is stored as a list of values from the time and times
+functions:
+
+ ($real, $user, $system, $children_user, $children_system, $iters)
+
+in seconds for the whole loop (not divided by the number of rounds).
+
+The timing is done using time(3) and times(3).
+
+Code is executed in the caller's package.
+
+The time of the null loop (a loop with the same
+number of rounds but empty loop body) is subtracted
+from the time of the real loop.
+
+The null loop times can be cached, the key being the
+number of rounds. The caching can be controlled using
+calls like these:
+
+ clearcache($key);
+ clearallcache();
+
+ disablecache();
+ enablecache();
+
+Caching is off by default, as it can (usually slightly) decrease
+accuracy and does not usually noticably affect runtimes.
+
+=head1 EXAMPLES
+
+For example,
+
+ use Benchmark qw( cmpthese ) ;
+ $x = 3;
+ cmpthese( -5, {
+ a => sub{$x*$x},
+ b => sub{$x**2},
+ } );
+
+outputs something like this:
+
+ Benchmark: running a, b, each for at least 5 CPU seconds...
+ Rate b a
+ b 1559428/s -- -62%
+ a 4152037/s 166% --
+
+
+while
+
+ use Benchmark qw( timethese cmpthese ) ;
+ $x = 3;
+ $r = timethese( -5, {
+ a => sub{$x*$x},
+ b => sub{$x**2},
+ } );
+ cmpthese $r;
+
+outputs something like this:
+
+ Benchmark: running a, b, each for at least 5 CPU seconds...
+ a: 10 wallclock secs ( 5.14 usr + 0.13 sys = 5.27 CPU) @ 3835055.60/s (n=20210743)
+ b: 5 wallclock secs ( 5.41 usr + 0.00 sys = 5.41 CPU) @ 1574944.92/s (n=8520452)
+ Rate b a
+ b 1574945/s -- -59%
+ a 3835056/s 144% --
+
+
+=head1 INHERITANCE
+
+Benchmark inherits from no other class, except of course
+for Exporter.
+
+=head1 CAVEATS
+
+Comparing eval'd strings with code references will give you
+inaccurate results: a code reference will show a slightly slower
+execution time than the equivalent eval'd string.
+
+The real time timing is done using time(2) and
+the granularity is therefore only one second.
+
+Short tests may produce negative figures because perl
+can appear to take longer to execute the empty loop
+than a short test; try:
+
+ timethis(100,'1');
+
+The system time of the null loop might be slightly
+more than the system time of the loop with the actual
+code and therefore the difference might end up being E<lt> 0.
+
+=head1 SEE ALSO
+
+L<Devel::DProf> - a Perl code profiler
+
+=head1 AUTHORS
+
+Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>
+
+=head1 MODIFICATION HISTORY
+
+September 8th, 1994; by Tim Bunce.
+
+March 28th, 1997; by Hugo van der Sanden: added support for code
+references and the already documented 'debug' method; revamped
+documentation.
+
+April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time
+functionality.
+
+September, 1999; by Barrie Slaymaker: math fixes and accuracy and
+efficiency tweaks. Added cmpthese(). A result is now returned from
+timethese(). Exposed countit() (was runfor()).
+
+December, 2001; by Nicholas Clark: make timestr() recognise the style 'none'
+and return an empty string. If cmpthese is calling timethese, make it pass the
+style in. (so that 'none' will suppress output). Make sub new dump its
+debugging output to STDERR, to be consistent with everything else.
+All bugs found while writing a regression test.
+
+September, 2002; by Jarkko Hietaniemi: add ':hireswallclock' special tag.
+
+February, 2004; by Chia-liang Kao: make cmpthese and timestr use time
+statistics for children instead of parent when the style is 'nop'.
+
+November, 2007; by Christophe Grosjean: make cmpthese and timestr compute
+time consistently with style argument, default is 'all' not 'noc' any more.
+
+=cut
+
+# evaluate something in a clean lexical environment
+sub _doeval { no strict; eval shift }
+
+#
+# put any lexicals at file scope AFTER here
+#
+
+use Carp;
+use Exporter;
+
+our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
+
+@ISA=qw(Exporter);
+@EXPORT=qw(timeit timethis timethese timediff timestr);
+@EXPORT_OK=qw(timesum cmpthese countit
+ clearcache clearallcache disablecache enablecache);
+%EXPORT_TAGS=( all => [ @EXPORT, @EXPORT_OK ] ) ;
+
+$VERSION = 1.11;
+
+# --- ':hireswallclock' special handling
+
+my $hirestime;
+
+sub mytime () { time }
+
+init();
+
+sub BEGIN {
+ if (eval 'require Time::HiRes') {
+ import Time::HiRes qw(time);
+ $hirestime = \&Time::HiRes::time;
+ }
+}
+
+sub import {
+ my $class = shift;
+ if (grep { $_ eq ":hireswallclock" } @_) {
+ @_ = grep { $_ ne ":hireswallclock" } @_;
+ local $^W=0;
+ *mytime = $hirestime if defined $hirestime;
+ }
+ Benchmark->export_to_level(1, $class, @_);
+}
+
+our($Debug, $Min_Count, $Min_CPU, $Default_Format, $Default_Style,
+ %_Usage, %Cache, $Do_Cache);
+
+sub init {
+ $Debug = 0;
+ $Min_Count = 4;
+ $Min_CPU = 0.4;
+ $Default_Format = '5.2f';
+ $Default_Style = 'auto';
+ # The cache can cause a slight loss of sys time accuracy. If a
+ # user does many tests (>10) with *very* large counts (>10000)
+ # or works on a very slow machine the cache may be useful.
+ disablecache();
+ clearallcache();
+}
+
+sub debug { $Debug = ($_[1] != 0); }
+
+sub usage {
+ my $calling_sub = (caller(1))[3];
+ $calling_sub =~ s/^Benchmark:://;
+ return $_Usage{$calling_sub} || '';
+}
+
+# The cache needs two branches: 's' for strings and 'c' for code. The
+# empty loop is different in these two cases.
+
+$_Usage{clearcache} = <<'USAGE';
+usage: clearcache($count);
+USAGE
+
+sub clearcache {
+ die usage unless @_ == 1;
+ delete $Cache{"$_[0]c"}; delete $Cache{"$_[0]s"};
+}
+
+$_Usage{clearallcache} = <<'USAGE';
+usage: clearallcache();
+USAGE
+
+sub clearallcache {
+ die usage if @_;
+ %Cache = ();
+}
+
+$_Usage{enablecache} = <<'USAGE';
+usage: enablecache();
+USAGE
+
+sub enablecache {
+ die usage if @_;
+ $Do_Cache = 1;
+}
+
+$_Usage{disablecache} = <<'USAGE';
+usage: disablecache();
+USAGE
+
+sub disablecache {
+ die usage if @_;
+ $Do_Cache = 0;
+}
+
+
+# --- Functions to process the 'time' data type
+
+sub new { my @t = (mytime, times, @_ == 2 ? $_[1] : 0);
+ print STDERR "new=@t\n" if $Debug;
+ bless \@t; }
+
+sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; }
+sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; }
+sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
+sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; }
+sub iters { $_[0]->[5] ; }
+
+
+$_Usage{timediff} = <<'USAGE';
+usage: $result_diff = timediff($result1, $result2);
+USAGE
+
+sub timediff {
+ my($a, $b) = @_;
+
+ die usage unless ref $a and ref $b;
+
+ my @r;
+ for (my $i=0; $i < @$a; ++$i) {
+ push(@r, $a->[$i] - $b->[$i]);
+ }
+ #die "Bad timediff(): ($r[1] + $r[2]) <= 0 (@$a[1,2]|@$b[1,2])\n"
+ # if ($r[1] + $r[2]) < 0;
+ bless \@r;
+}
+
+$_Usage{timesum} = <<'USAGE';
+usage: $sum = timesum($result1, $result2);
+USAGE
+
+sub timesum {
+ my($a, $b) = @_;
+
+ die usage unless ref $a and ref $b;
+
+ my @r;
+ for (my $i=0; $i < @$a; ++$i) {
+ push(@r, $a->[$i] + $b->[$i]);
+ }
+ bless \@r;
+}
+
+
+$_Usage{timestr} = <<'USAGE';
+usage: $formatted_result = timestr($result1);
+USAGE
+
+sub timestr {
+ my($tr, $style, $f) = @_;
+
+ die usage unless ref $tr;
+
+ my @t = @$tr;
+ warn "bad time value (@t)" unless @t==6;
+ my($r, $pu, $ps, $cu, $cs, $n) = @t;
+ my($pt, $ct, $tt) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
+ $f = $Default_Format unless defined $f;
+ # format a time in the required style, other formats may be added here
+ $style ||= $Default_Style;
+ return '' if $style eq 'none';
+ $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto';
+ my $s = "@t $style"; # default for unknown style
+ my $w = $hirestime ? "%2g" : "%2d";
+ $s = sprintf("$w wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
+ $r,$pu,$ps,$cu,$cs,$tt) if $style eq 'all';
+ $s = sprintf("$w wallclock secs (%$f usr + %$f sys = %$f CPU)",
+ $r,$pu,$ps,$pt) if $style eq 'noc';
+ $s = sprintf("$w wallclock secs (%$f cusr + %$f csys = %$f CPU)",
+ $r,$cu,$cs,$ct) if $style eq 'nop';
+ my $elapsed = do {
+ if ($style eq 'nop') {$cu+$cs}
+ elsif ($style eq 'noc') {$pu+$ps}
+ else {$cu+$cs+$pu+$ps}
+ };
+ $s .= sprintf(" @ %$f/s (n=$n)",$n/($elapsed)) if $n && $elapsed;
+ $s;
+}
+
+sub timedebug {
+ my($msg, $t) = @_;
+ print STDERR "$msg",timestr($t),"\n" if $Debug;
+}
+
+# --- Functions implementing low-level support for timing loops
+
+$_Usage{runloop} = <<'USAGE';
+usage: runloop($number, [$string | $coderef])
+USAGE
+
+sub runloop {
+ my($n, $c) = @_;
+
+ $n+=0; # force numeric now, so garbage won't creep into the eval
+ croak "negative loopcount $n" if $n<0;
+ confess usage unless defined $c;
+ my($t0, $t1, $td); # before, after, difference
+
+ # find package of caller so we can execute code there
+ my($curpack) = caller(0);
+ my($i, $pack)= 0;
+ while (($pack) = caller(++$i)) {
+ last if $pack ne $curpack;
+ }
+
+ my ($subcode, $subref);
+ if (ref $c eq 'CODE') {
+ $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }";
+ $subref = eval $subcode;
+ }
+ else {
+ $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }";
+ $subref = _doeval($subcode);
+ }
+ croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
+ print STDERR "runloop $n '$subcode'\n" if $Debug;
+
+ # Wait for the user timer to tick. This makes the error range more like
+ # -0.01, +0. If we don't wait, then it's more like -0.01, +0.01. This
+ # may not seem important, but it significantly reduces the chances of
+ # getting a too low initial $n in the initial, 'find the minimum' loop
+ # in &countit. This, in turn, can reduce the number of calls to
+ # &runloop a lot, and thus reduce additive errors.
+ my $tbase = Benchmark->new(0)->[1];
+ while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) {} ;
+ $subref->();
+ $t1 = Benchmark->new($n);
+ $td = &timediff($t1, $t0);
+ timedebug("runloop:",$td);
+ $td;
+}
+
+$_Usage{timeit} = <<'USAGE';
+usage: $result = timeit($count, 'code' ); or
+ $result = timeit($count, sub { code } );
+USAGE
+
+sub timeit {
+ my($n, $code) = @_;
+ my($wn, $wc, $wd);
+
+ die usage unless defined $code and
+ (!ref $code or ref $code eq 'CODE');
+
+ printf STDERR "timeit $n $code\n" if $Debug;
+ my $cache_key = $n . ( ref( $code ) ? 'c' : 's' );
+ if ($Do_Cache && exists $Cache{$cache_key} ) {
+ $wn = $Cache{$cache_key};
+ } else {
+ $wn = &runloop($n, ref( $code ) ? sub { } : '' );
+ # Can't let our baseline have any iterations, or they get subtracted
+ # out of the result.
+ $wn->[5] = 0;
+ $Cache{$cache_key} = $wn;
+ }
+
+ $wc = &runloop($n, $code);
+
+ $wd = timediff($wc, $wn);
+ timedebug("timeit: ",$wc);
+ timedebug(" - ",$wn);
+ timedebug(" = ",$wd);
+
+ $wd;
+}
+
+
+my $default_for = 3;
+my $min_for = 0.1;
+
+
+$_Usage{countit} = <<'USAGE';
+usage: $result = countit($time, 'code' ); or
+ $result = countit($time, sub { code } );
+USAGE
+
+sub countit {
+ my ( $tmax, $code ) = @_;
+
+ die usage unless @_;
+
+ if ( not defined $tmax or $tmax == 0 ) {
+ $tmax = $default_for;
+ } elsif ( $tmax < 0 ) {
+ $tmax = -$tmax;
+ }
+
+ die "countit($tmax, ...): timelimit cannot be less than $min_for.\n"
+ if $tmax < $min_for;
+
+ my ($n, $tc);
+
+ # First find the minimum $n that gives a significant timing.
+ my $zeros=0;
+ for ($n = 1; ; $n *= 2 ) {
+ my $td = timeit($n, $code);
+ $tc = $td->[1] + $td->[2];
+ if ( $tc <= 0 and $n > 1024 ) {
+ ++$zeros > 16
+ and die "Timing is consistently zero in estimation loop, cannot benchmark. N=$n\n";
+ } else {
+ $zeros = 0;
+ }
+ last if $tc > 0.1;
+ }
+
+ my $nmin = $n;
+
+ # Get $n high enough that we can guess the final $n with some accuracy.
+ my $tpra = 0.1 * $tmax; # Target/time practice.
+ while ( $tc < $tpra ) {
+ # The 5% fudge is to keep us from iterating again all
+ # that often (this speeds overall responsiveness when $tmax is big
+ # and we guess a little low). This does not noticably affect
+ # accuracy since we're not couting these times.
+ $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation.
+ my $td = timeit($n, $code);
+ my $new_tc = $td->[1] + $td->[2];
+ # Make sure we are making progress.
+ $tc = $new_tc > 1.2 * $tc ? $new_tc : 1.2 * $tc;
+ }
+
+ # Now, do the 'for real' timing(s), repeating until we exceed
+ # the max.
+ my $ntot = 0;
+ my $rtot = 0;
+ my $utot = 0.0;
+ my $stot = 0.0;
+ my $cutot = 0.0;
+ my $cstot = 0.0;
+ my $ttot = 0.0;
+
+ # The 5% fudge is because $n is often a few % low even for routines
+ # with stable times and avoiding extra timeit()s is nice for
+ # accuracy's sake.
+ $n = int( $n * ( 1.05 * $tmax / $tc ) );
+ $zeros=0;
+ while () {
+ my $td = timeit($n, $code);
+ $ntot += $n;
+ $rtot += $td->[0];
+ $utot += $td->[1];
+ $stot += $td->[2];
+ $cutot += $td->[3];
+ $cstot += $td->[4];
+ $ttot = $utot + $stot;
+ last if $ttot >= $tmax;
+ if ( $ttot <= 0 ) {
+ ++$zeros > 16
+ and die "Timing is consistently zero, cannot benchmark. N=$n\n";
+ } else {
+ $zeros = 0;
+ }
+ $ttot = 0.01 if $ttot < 0.01;
+ my $r = $tmax / $ttot - 1; # Linear approximation.
+ $n = int( $r * $ntot );
+ $n = $nmin if $n < $nmin;
+ }
+
+ return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ];
+}
+
+# --- Functions implementing high-level time-then-print utilities
+
+sub n_to_for {
+ my $n = shift;
+ return $n == 0 ? $default_for : $n < 0 ? -$n : undef;
+}
+
+$_Usage{timethis} = <<'USAGE';
+usage: $result = timethis($time, 'code' ); or
+ $result = timethis($time, sub { code } );
+USAGE
+
+sub timethis{
+ my($n, $code, $title, $style) = @_;
+ my($t, $forn);
+
+ die usage unless defined $code and
+ (!ref $code or ref $code eq 'CODE');
+
+ if ( $n > 0 ) {
+ croak "non-integer loopcount $n, stopped" if int($n)<$n;
+ $t = timeit($n, $code);
+ $title = "timethis $n" unless defined $title;
+ } else {
+ my $fort = n_to_for( $n );
+ $t = countit( $fort, $code );
+ $title = "timethis for $fort" unless defined $title;
+ $forn = $t->[-1];
+ }
+ local $| = 1;
+ $style = "" unless defined $style;
+ printf("%10s: ", $title) unless $style eq 'none';
+ print timestr($t, $style, $Default_Format),"\n" unless $style eq 'none';
+
+ $n = $forn if defined $forn;
+
+ # A conservative warning to spot very silly tests.
+ # Don't assume that your benchmark is ok simply because
+ # you don't get this warning!
+ print " (warning: too few iterations for a reliable count)\n"
+ if $n < $Min_Count
+ || ($t->real < 1 && $n < 1000)
+ || $t->cpu_a < $Min_CPU;
+ $t;
+}
+
+
+$_Usage{timethese} = <<'USAGE';
+usage: timethese($count, { Name1 => 'code1', ... }); or
+ timethese($count, { Name1 => sub { code1 }, ... });
+USAGE
+
+sub timethese{
+ my($n, $alt, $style) = @_;
+ die usage unless ref $alt eq 'HASH';
+
+ my @names = sort keys %$alt;
+ $style = "" unless defined $style;
+ print "Benchmark: " unless $style eq 'none';
+ if ( $n > 0 ) {
+ croak "non-integer loopcount $n, stopped" if int($n)<$n;
+ print "timing $n iterations of" unless $style eq 'none';
+ } else {
+ print "running" unless $style eq 'none';
+ }
+ print " ", join(', ',@names) unless $style eq 'none';
+ unless ( $n > 0 ) {
+ my $for = n_to_for( $n );
+ print ", each" if $n > 1 && $style ne 'none';
+ print " for at least $for CPU seconds" unless $style eq 'none';
+ }
+ print "...\n" unless $style eq 'none';
+
+ # we could save the results in an array and produce a summary here
+ # sum, min, max, avg etc etc
+ my %results;
+ foreach my $name (@names) {
+ $results{$name} = timethis ($n, $alt -> {$name}, $name, $style);
+ }
+
+ return \%results;
+}
+
+
+$_Usage{cmpthese} = <<'USAGE';
+usage: cmpthese($count, { Name1 => 'code1', ... }); or
+ cmpthese($count, { Name1 => sub { code1 }, ... }); or
+ cmpthese($result, $style);
+USAGE
+
+sub cmpthese{
+ my ($results, $style);
+
+ # $count can be a blessed object.
+ if ( ref $_[0] eq 'HASH' ) {
+ ($results, $style) = @_;
+ }
+ else {
+ my($count, $code) = @_[0,1];
+ $style = $_[2] if defined $_[2];
+
+ die usage unless ref $code eq 'HASH';
+
+ $results = timethese($count, $code, ($style || "none"));
+ }
+
+ $style = "" unless defined $style;
+
+ # Flatten in to an array of arrays with the name as the first field
+ my @vals = map{ [ $_, @{$results->{$_}} ] } keys %$results;
+
+ for (@vals) {
+ # The epsilon fudge here is to prevent div by 0. Since clock
+ # resolutions are much larger, it's below the noise floor.
+ my $elapsed = do {
+ if ($style eq 'nop') {$_->[4]+$_->[5]}
+ elsif ($style eq 'noc') {$_->[2]+$_->[3]}
+ else {$_->[2]+$_->[3]+$_->[4]+$_->[5]}
+ };
+ my $rate = $_->[6]/(($elapsed)+0.000000000000001);
+ $_->[7] = $rate;
+ }
+
+ # Sort by rate
+ @vals = sort { $a->[7] <=> $b->[7] } @vals;
+
+ # If more than half of the rates are greater than one...
+ my $display_as_rate = @vals ? ($vals[$#vals>>1]->[7] > 1) : 0;
+
+ my @rows;
+ my @col_widths;
+
+ my @top_row = (
+ '',
+ $display_as_rate ? 'Rate' : 's/iter',
+ map { $_->[0] } @vals
+ );
+
+ push @rows, \@top_row;
+ @col_widths = map { length( $_ ) } @top_row;
+
+ # Build the data rows
+ # We leave the last column in even though it never has any data. Perhaps
+ # it should go away. Also, perhaps a style for a single column of
+ # percentages might be nice.
+ for my $row_val ( @vals ) {
+ my @row;
+
+ # Column 0 = test name
+ push @row, $row_val->[0];
+ $col_widths[0] = length( $row_val->[0] )
+ if length( $row_val->[0] ) > $col_widths[0];
+
+ # Column 1 = performance
+ my $row_rate = $row_val->[7];
+
+ # We assume that we'll never get a 0 rate.
+ my $rate = $display_as_rate ? $row_rate : 1 / $row_rate;
+
+ # Only give a few decimal places before switching to sci. notation,
+ # since the results aren't usually that accurate anyway.
+ my $format =
+ $rate >= 100 ?
+ "%0.0f" :
+ $rate >= 10 ?
+ "%0.1f" :
+ $rate >= 1 ?
+ "%0.2f" :
+ $rate >= 0.1 ?
+ "%0.3f" :
+ "%0.2e";
+
+ $format .= "/s"
+ if $display_as_rate;
+
+ my $formatted_rate = sprintf( $format, $rate );
+ push @row, $formatted_rate;
+ $col_widths[1] = length( $formatted_rate )
+ if length( $formatted_rate ) > $col_widths[1];
+
+ # Columns 2..N = performance ratios
+ my $skip_rest = 0;
+ for ( my $col_num = 0 ; $col_num < @vals ; ++$col_num ) {
+ my $col_val = $vals[$col_num];
+ my $out;
+ if ( $skip_rest ) {
+ $out = '';
+ }
+ elsif ( $col_val->[0] eq $row_val->[0] ) {
+ $out = "--";
+ # $skip_rest = 1;
+ }
+ else {
+ my $col_rate = $col_val->[7];
+ $out = sprintf( "%.0f%%", 100*$row_rate/$col_rate - 100 );
+ }
+ push @row, $out;
+ $col_widths[$col_num+2] = length( $out )
+ if length( $out ) > $col_widths[$col_num+2];
+
+ # A little wierdness to set the first column width properly
+ $col_widths[$col_num+2] = length( $col_val->[0] )
+ if length( $col_val->[0] ) > $col_widths[$col_num+2];
+ }
+ push @rows, \@row;
+ }
+
+ return \@rows if $style eq "none";
+
+ # Equalize column widths in the chart as much as possible without
+ # exceeding 80 characters. This does not use or affect cols 0 or 1.
+ my @sorted_width_refs =
+ sort { $$a <=> $$b } map { \$_ } @col_widths[2..$#col_widths];
+ my $max_width = ${$sorted_width_refs[-1]};
+
+ my $total = @col_widths - 1 ;
+ for ( @col_widths ) { $total += $_ }
+
+ STRETCHER:
+ while ( $total < 80 ) {
+ my $min_width = ${$sorted_width_refs[0]};
+ last
+ if $min_width == $max_width;
+ for ( @sorted_width_refs ) {
+ last
+ if $$_ > $min_width;
+ ++$$_;
+ ++$total;
+ last STRETCHER
+ if $total >= 80;
+ }
+ }
+
+ # Dump the output
+ my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n";
+ substr( $format, 1, 0 ) = '-';
+ for ( @rows ) {
+ printf $format, @$_;
+ }
+
+ return \@rows ;
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CGI.pm b/Master/tlpkg/tlperl/lib/CGI.pm
new file mode 100644
index 00000000000..1f195606c10
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CGI.pm
@@ -0,0 +1,8096 @@
+package CGI;
+require 5.004;
+use Carp 'croak';
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://stein.cshl.org/WWW/software/CGI/
+
+$CGI::revision = '$Id: CGI.pm,v 1.266 2009/07/30 16:32:34 lstein Exp $';
+$CGI::VERSION='3.49';
+
+# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
+# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
+# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
+use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
+
+#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
+# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
+
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+ 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
+
+{
+ local $^W = 0;
+ $TAINTED = substr("$0$^X",0,0);
+}
+
+$MOD_PERL = 0; # no mod_perl by default
+
+#global settings
+$POST_MAX = -1; # no limit to uploaded files
+$DISABLE_UPLOADS = 0;
+
+@SAVED_SYMBOLS = ();
+
+
+# >>>>> Here are some globals that you might want to adjust <<<<<<
+sub initialize_globals {
+ # Set this to 1 to enable copious autoloader debugging messages
+ $AUTOLOAD_DEBUG = 0;
+
+ # Set this to 1 to generate XTML-compatible output
+ $XHTML = 1;
+
+ # Change this to the preferred DTD to print in start_html()
+ # or use default_dtd('text of DTD to use');
+ $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
+ 'http://www.w3.org/TR/html4/loose.dtd' ] ;
+
+ # Set this to 1 to enable NOSTICKY scripts
+ # or:
+ # 1) use CGI '-nosticky';
+ # 2) $CGI::NOSTICKY = 1;
+ $NOSTICKY = 0;
+
+ # Set this to 1 to enable NPH scripts
+ # or:
+ # 1) use CGI qw(-nph)
+ # 2) CGI::nph(1)
+ # 3) print header(-nph=>1)
+ $NPH = 0;
+
+ # Set this to 1 to enable debugging from @ARGV
+ # Set to 2 to enable debugging from STDIN
+ $DEBUG = 1;
+
+ # Set this to 1 to make the temporary files created
+ # during file uploads safe from prying eyes
+ # or do...
+ # 1) use CGI qw(:private_tempfiles)
+ # 2) CGI::private_tempfiles(1);
+ $PRIVATE_TEMPFILES = 0;
+
+ # Set this to 1 to generate automatic tab indexes
+ $TABINDEX = 0;
+
+ # Set this to 1 to cause files uploaded in multipart documents
+ # to be closed, instead of caching the file handle
+ # or:
+ # 1) use CGI qw(:close_upload_files)
+ # 2) $CGI::close_upload_files(1);
+ # Uploads with many files run out of file handles.
+ # Also, for performance, since the file is already on disk,
+ # it can just be renamed, instead of read and written.
+ $CLOSE_UPLOAD_FILES = 0;
+
+ # Automatically determined -- don't change
+ $EBCDIC = 0;
+
+ # Change this to 1 to suppress redundant HTTP headers
+ $HEADERS_ONCE = 0;
+
+ # separate the name=value pairs by semicolons rather than ampersands
+ $USE_PARAM_SEMICOLONS = 1;
+
+ # Do not include undefined params parsed from query string
+ # use CGI qw(-no_undef_params);
+ $NO_UNDEF_PARAMS = 0;
+
+ # return everything as utf-8
+ $PARAM_UTF8 = 0;
+
+ # Other globals that you shouldn't worry about.
+ undef $Q;
+ $BEEN_THERE = 0;
+ $DTD_PUBLIC_IDENTIFIER = "";
+ undef @QUERY_PARAM;
+ undef %EXPORT;
+ undef $QUERY_CHARSET;
+ undef %QUERY_FIELDNAMES;
+ undef %QUERY_TMPFILES;
+
+ # prevent complaints by mod_perl
+ 1;
+}
+
+# ------------------ START OF THE LIBRARY ------------
+
+#### Method: endform
+# This method is DEPRECATED
+*endform = \&end_form;
+
+# make mod_perlhappy
+initialize_globals();
+
+# FIGURE OUT THE OS WE'RE RUNNING UNDER
+# Some systems support the $^O variable. If not
+# available then require() the Config library
+unless ($OS) {
+ unless ($OS = $^O) {
+ require Config;
+ $OS = $Config::Config{'osname'};
+ }
+}
+if ($OS =~ /^MSWin/i) {
+ $OS = 'WINDOWS';
+} elsif ($OS =~ /^VMS/i) {
+ $OS = 'VMS';
+} elsif ($OS =~ /^dos/i) {
+ $OS = 'DOS';
+} elsif ($OS =~ /^MacOS/i) {
+ $OS = 'MACINTOSH';
+} elsif ($OS =~ /^os2/i) {
+ $OS = 'OS2';
+} elsif ($OS =~ /^epoc/i) {
+ $OS = 'EPOC';
+} elsif ($OS =~ /^cygwin/i) {
+ $OS = 'CYGWIN';
+} elsif ($OS =~ /^NetWare/i) {
+ $OS = 'NETWARE';
+} else {
+ $OS = 'UNIX';
+}
+
+# Some OS logic. Binary mode enabled on DOS, NT and VMS
+$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/;
+
+# This is the default class for the CGI object to use when all else fails.
+$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
+
+# This is where to look for autoloaded routines.
+$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
+
+# The path separator is a slash, backslash or semicolon, depending
+# on the paltform.
+$SL = {
+ UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/',
+ WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
+ }->{$OS};
+
+# This no longer seems to be necessary
+# Turn on NPH scripts by default when running under IIS server!
+# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+
+# Turn on special checking for 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
+if (exists $ENV{MOD_PERL} && ! $PERLEX) {
+ # mod_perl handlers may run system() on scripts using CGI.pm;
+ # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
+ if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
+ $MOD_PERL = 2;
+ require Apache2::Response;
+ require Apache2::RequestRec;
+ require Apache2::RequestUtil;
+ require Apache2::RequestIO;
+ require APR::Pool;
+ } else {
+ $MOD_PERL = 1;
+ require Apache;
+ }
+}
+
+# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
+# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
+# and sometimes CR). The most popular VMS web server
+# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
+# use ASCII, so \015\012 means something different. I find this all
+# really annoying.
+$EBCDIC = "\t" ne "\011";
+if ($OS eq 'VMS') {
+ $CRLF = "\n";
+} elsif ($EBCDIC) {
+ $CRLF= "\r\n";
+} else {
+ $CRLF = "\015\012";
+}
+
+if ($needs_binmode) {
+ $CGI::DefaultClass->binmode(\*main::STDOUT);
+ $CGI::DefaultClass->binmode(\*main::STDIN);
+ $CGI::DefaultClass->binmode(\*main::STDERR);
+}
+
+%EXPORT_TAGS = (
+ ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
+ tt u i b blockquote pre img a address cite samp dfn html head
+ base body Link nextid title meta kbd start_html end_html
+ input Select option comment charset escapeHTML/],
+ ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
+ embed basefont style span layer ilayer font frameset frame script small big Area Map/],
+ ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
+ ins label legend noframes noscript object optgroup Q
+ thead tbody tfoot/],
+ ':netscape'=>[qw/blink fontsize center/],
+ ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
+ submit reset defaults radio_group popup_menu button autoEscape
+ scrolling_list image_button start_form end_form startform endform
+ start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
+ ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
+ cookie Dump
+ raw_cookie request_method query_string Accept user_agent remote_host content_type
+ remote_addr referer server_name server_software server_port server_protocol virtual_port
+ virtual_host remote_ident auth_type http append
+ save_parameters restore_parameters param_fetch
+ remote_user user_name header redirect import_names put
+ Delete Delete_all url_param cgi_error/],
+ ':ssl' => [qw/https/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
+ ':html' => [qw/:html2 :html3 :html4 :netscape/],
+ ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
+ ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
+ );
+
+# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
+# Author: Cees Hek <cees@sitesuite.com.au>
+
+sub can {
+ my($class, $method) = @_;
+
+ # See if UNIVERSAL::can finds it.
+
+ if (my $func = $class -> SUPER::can($method) ){
+ return $func;
+ }
+
+ # Try to compile the function.
+
+ eval {
+ # _compile looks at $AUTOLOAD for the function name.
+
+ local $AUTOLOAD = join "::", $class, $method;
+ &_compile;
+ };
+
+ # Now that the function is loaded (if it exists)
+ # just use UNIVERSAL::can again to do the work.
+
+ return $class -> SUPER::can($method);
+}
+
+# to import symbols into caller
+sub import {
+ my $self = shift;
+
+ # This causes modules to clash.
+ undef %EXPORT_OK;
+ undef %EXPORT;
+
+ $self->_setup_symbols(@_);
+ my ($callpack, $callfile, $callline) = caller;
+
+ # To allow overriding, search through the packages
+ # Till we find one in which the correct subroutine is defined.
+ my @packages = ($self,@{"$self\:\:ISA"});
+ for $sym (keys %EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
+ for $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+sub compile {
+ my $pack = shift;
+ $pack->_setup_symbols('-compile',@_);
+}
+
+sub expand_tags {
+ my($tag) = @_;
+ return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
+ my(@r);
+ return ($tag) unless $EXPORT_TAGS{$tag};
+ for (@{$EXPORT_TAGS{$tag}}) {
+ push(@r,&expand_tags($_));
+ }
+ return @r;
+}
+
+#### Method: new
+# The new routine. This will check the current environment
+# for an existing query string, and initialize itself, if so.
+####
+sub new {
+ my($class,@initializer) = @_;
+ my $self = {};
+
+ bless $self,ref $class || $class || $DefaultClass;
+
+ # always use a tempfile
+ $self->{'use_tempfile'} = 1;
+
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'Apache')
+ ||
+ UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
+ )) {
+ $self->r(shift @initializer);
+ }
+ if (ref($initializer[0])
+ && (UNIVERSAL::isa($initializer[0],'CODE'))) {
+ $self->upload_hook(shift @initializer, shift @initializer);
+ $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
+ }
+ if ($MOD_PERL) {
+ if ($MOD_PERL == 1) {
+ $self->r(Apache->request) unless $self->r;
+ my $r = $self->r;
+ $r->register_cleanup(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
+ }
+ else {
+ # XXX: once we have the new API
+ # will do a real PerlOptions -SetupEnv check
+ $self->r(Apache2::RequestUtil->request) unless $self->r;
+ my $r = $self->r;
+ $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
+ $r->pool->cleanup_register(\&CGI::_reset_globals);
+ $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
+ }
+ undef $NPH;
+ }
+ $self->_reset_globals if $PERLEX;
+ $self->init(@initializer);
+ return $self;
+}
+
+# We provide a DESTROY method so that we can ensure that
+# temporary files are closed (via Fh->DESTROY) before they
+# are unlinked (via CGITempFile->DESTROY) because it is not
+# possible to unlink an open file on Win32. We explicitly
+# call DESTROY on each, rather than just undefing them and
+# letting Perl DESTROY them by garbage collection, in case the
+# user is still holding any reference to them as well.
+sub DESTROY {
+ my $self = shift;
+ if ($OS eq 'WINDOWS') {
+ for my $href (values %{$self->{'.tmpfiles'}}) {
+ $href->{hndl}->DESTROY if defined $href->{hndl};
+ $href->{name}->DESTROY if defined $href->{name};
+ }
+ }
+}
+
+sub r {
+ my $self = shift;
+ my $r = $self->{'.r'};
+ $self->{'.r'} = shift if @_;
+ $r;
+}
+
+sub upload_hook {
+ my $self;
+ if (ref $_[0] eq 'CODE') {
+ $CGI::Q = $self = $CGI::DefaultClass->new(@_);
+ } else {
+ $self = shift;
+ }
+ my ($hook,$data,$use_tempfile) = @_;
+ $self->{'.upload_hook'} = $hook;
+ $self->{'.upload_data'} = $data;
+ $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
+}
+
+#### Method: param
+# Returns the value(s)of a named parameter.
+# If invoked in a list context, returns the
+# entire list. Otherwise returns the first
+# member of the list.
+# If name is not provided, return a list of all
+# the known parameters names available.
+# If more than one argument is provided, the
+# second and subsequent arguments are used to
+# set the value of the parameter.
+####
+sub param {
+ my($self,@p) = self_or_default(@_);
+ return $self->all_parameters unless @p;
+ my($name,$value,@other);
+
+ # For compatibility between old calling style and use_named_parameters() style,
+ # we have to special case for a single parameter present.
+ if (@p > 1) {
+ ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
+ my(@values);
+
+ if (substr($p[0],0,1) eq '-') {
+ @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
+ } else {
+ for ($value,@other) {
+ push(@values,$_) if defined($_);
+ }
+ }
+ # If values is provided, then we set it.
+ if (@values or defined $value) {
+ $self->add_parameter($name);
+ $self->{param}{$name}=[@values];
+ }
+ } else {
+ $name = $p[0];
+ }
+
+ return unless defined($name) && $self->{param}{$name};
+
+ my @result = @{$self->{param}{$name}};
+
+ if ($PARAM_UTF8) {
+ eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
+ @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result;
+ }
+
+ return wantarray ? @result : $result[0];
+}
+
+sub _decode_utf8 {
+ my ($self, $val) = @_;
+
+ if (Encode::is_utf8($val)) {
+ return $val;
+ }
+ else {
+ return Encode::decode(utf8 => $val);
+ }
+}
+
+sub self_or_default {
+ return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
+ unless (defined($_[0]) &&
+ (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
+ ) {
+ $Q = $CGI::DefaultClass->new unless defined($Q);
+ unshift(@_,$Q);
+ }
+ return wantarray ? @_ : $Q;
+}
+
+sub self_or_CGI {
+ local $^W=0; # prevent a warning
+ if (defined($_[0]) &&
+ (substr(ref($_[0]),0,3) eq 'CGI'
+ || UNIVERSAL::isa($_[0],'CGI'))) {
+ return @_;
+ } else {
+ return ($DefaultClass,@_);
+ }
+}
+
+########################################
+# THESE METHODS ARE MORE OR LESS PRIVATE
+# GO TO THE __DATA__ SECTION TO SEE MORE
+# PUBLIC METHODS
+########################################
+
+# Initialize the query object from the environment.
+# If a parameter list is found, this object will be set
+# to a hash in which parameter names are keys
+# and the values are stored as lists
+# If a keyword list is found, this method creates a bogus
+# parameter list with the single parameter 'keywords'.
+
+sub init {
+ my $self = shift;
+ my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+
+ my $is_xforms;
+
+ my $initializer = shift; # for backward compatibility
+ local($/) = "\n";
+
+ # set autoescaping on by default
+ $self->{'escape'} = 1;
+
+ # if we get called more than once, we want to initialize
+ # ourselves from the original query (which may be gone
+ # if it was read from STDIN originally.)
+ if (defined(@QUERY_PARAM) && !defined($initializer)) {
+ for my $name (@QUERY_PARAM) {
+ my $val = $QUERY_PARAM{$name}; # always an arrayref;
+ $self->param('-name'=>$name,'-value'=> $val);
+ if (defined $val and ref $val eq 'ARRAY') {
+ for my $fh (grep {defined(fileno($_))} @$val) {
+ seek($fh,0,0); # reset the filehandle.
+ }
+
+ }
+ }
+ $self->charset($QUERY_CHARSET);
+ $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
+ $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
+ return;
+ }
+
+ $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
+ $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
+
+ $fh = to_filehandle($initializer) if $initializer;
+
+ # set charset to the safe ISO-8859-1
+ $self->charset('ISO-8859-1');
+
+ METHOD: {
+
+ # avoid unreasonably large postings
+ if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+ #discard the post, unread
+ $self->cgi_error("413 Request entity too large");
+ last METHOD;
+ }
+
+ # Process multipart postings, but only if the initializer is
+ # not defined.
+ if ($meth eq 'POST'
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
+ && !defined($initializer)
+ ) {
+ my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
+ $self->read_multipart($boundary,$content_length);
+ last METHOD;
+ }
+
+ # Process XForms postings. We know that we have XForms in the
+ # following cases:
+ # method eq 'POST' && content-type eq 'application/xml'
+ # method eq 'POST' && content-type =~ /multipart\/related.+start=/
+ # There are more cases, actually, but for now, we don't support other
+ # methods for XForm posts.
+ # In a XForm POST, the QUERY_STRING is parsed normally.
+ # If the content-type is 'application/xml', we just set the param
+ # XForms:Model (referring to the xml syntax) param containing the
+ # unparsed XML data.
+ # In the case of multipart/related we set XForms:Model as above, but
+ # the other parts are available as uploads with the Content-ID as the
+ # the key.
+ # See the URL below for XForms specs on this issue.
+ # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
+ if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
+ if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
+ my($param) = 'XForms:Model';
+ my($value) = '';
+ $self->add_parameter($param);
+ $self->read_from_client(\$value,$content_length,0)
+ if $content_length > 0;
+ push (@{$self->{param}{$param}},$value);
+ $is_xforms = 1;
+ } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
+ my($boundary,$start) = ($1,$2);
+ my($param) = 'XForms:Model';
+ $self->add_parameter($param);
+ my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
+ push (@{$self->{param}{$param}},$value);
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ $is_xforms = 1;
+ }
+ }
+
+
+ # If initializer is defined, then read parameters
+ # from it.
+ if (!$is_xforms && defined($initializer)) {
+ if (UNIVERSAL::isa($initializer,'CGI')) {
+ $query_string = $initializer->query_string;
+ last METHOD;
+ }
+ if (ref($initializer) && ref($initializer) eq 'HASH') {
+ for (keys %$initializer) {
+ $self->param('-name'=>$_,'-value'=>$initializer->{$_});
+ }
+ last METHOD;
+ }
+
+ if (defined($fh) && ($fh ne '')) {
+ while (my $line = <$fh>) {
+ chomp $line;
+ last if $line =~ /^=$/;
+ push(@lines,$line);
+ }
+ # massage back into standard format
+ if ("@lines" =~ /=/) {
+ $query_string=join("&",@lines);
+ } else {
+ $query_string=join("+",@lines);
+ }
+ last METHOD;
+ }
+
+ # last chance -- treat it as a string
+ $initializer = $$initializer if ref($initializer) eq 'SCALAR';
+ $query_string = $initializer;
+
+ last METHOD;
+ }
+
+ # If method is GET or HEAD, fetch the query from
+ # the environment.
+ if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
+ if ($MOD_PERL) {
+ $query_string = $self->r->args;
+ } else {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
+ }
+ last METHOD;
+ }
+
+ if ($meth eq 'POST' || $meth eq 'PUT') {
+ if ( $content_length > 0 ) {
+ $self->read_from_client(\$query_string,$content_length,0);
+ }
+ elsif (not defined $ENV{CONTENT_LENGTH}) {
+ $self->read_from_stdin(\$query_string);
+ # should this be PUTDATA in case of PUT ?
+ my($param) = $meth . 'DATA' ;
+ $self->add_parameter($param) ;
+ push (@{$self->{param}{$param}},$query_string);
+ undef $query_string ;
+ }
+ # Some people want to have their cake and eat it too!
+ # Uncomment this line to have the contents of the query string
+ # APPENDED to the POST data.
+ # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ # If $meth is not of GET, POST, PUT or HEAD, assume we're
+ # being debugged offline.
+ # Check the command line and then the standard input for data.
+ # We use the shellwords package in order to behave the way that
+ # UN*X programmers expect.
+ if ($DEBUG)
+ {
+ my $cmdline_ret = read_from_cmdline();
+ $query_string = $cmdline_ret->{'query_string'};
+ if (defined($cmdline_ret->{'subpath'}))
+ {
+ $self->path_info($cmdline_ret->{'subpath'});
+ }
+ }
+ }
+
+# YL: Begin Change for XML handler 10/19/2001
+ if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
+ && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
+ my($param) = $meth . 'DATA' ;
+ $self->add_parameter($param) ;
+ push (@{$self->{param}{$param}},$query_string);
+ undef $query_string ;
+ }
+# YL: End Change for XML handler 10/19/2001
+
+ # We now have the query string in hand. We do slightly
+ # different things for keyword lists and parameter lists.
+ if (defined $query_string && length $query_string) {
+ if ($query_string =~ /[&=;]/) {
+ $self->parse_params($query_string);
+ } else {
+ $self->add_parameter('keywords');
+ $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
+ }
+ }
+
+ # Special case. Erase everything if there is a field named
+ # .defaults.
+ if ($self->param('.defaults')) {
+ $self->delete_all();
+ }
+
+ # hash containing our defined fieldnames
+ $self->{'.fieldnames'} = {};
+ for ($self->param('.cgifields')) {
+ $self->{'.fieldnames'}->{$_}++;
+ }
+
+ # Clear out our default submission button flag if present
+ $self->delete('.submit');
+ $self->delete('.cgifields');
+
+ $self->save_request unless defined $initializer;
+}
+
+# FUNCTIONS TO OVERRIDE:
+# Turn a string into a filehandle
+sub to_filehandle {
+ my $thingy = shift;
+ return undef unless $thingy;
+ return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+ return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+ if (!ref($thingy)) {
+ my $caller = 1;
+ while (my $package = caller($caller++)) {
+ my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
+ return $tmp if defined(fileno($tmp));
+ }
+ }
+ return undef;
+}
+
+# send output to the browser
+sub put {
+ my($self,@p) = self_or_default(@_);
+ $self->print(@p);
+}
+
+# print to standard output (for overriding in mod_perl)
+sub print {
+ shift;
+ CORE::print(@_);
+}
+
+# get/set last cgi_error
+sub cgi_error {
+ my ($self,$err) = self_or_default(@_);
+ $self->{'.cgi_error'} = $err if defined $err;
+ return $self->{'.cgi_error'};
+}
+
+sub save_request {
+ my($self) = @_;
+ # We're going to play with the package globals now so that if we get called
+ # again, we initialize ourselves in exactly the same way. This allows
+ # us to have several of these objects.
+ @QUERY_PARAM = $self->param; # save list of parameters
+ for (@QUERY_PARAM) {
+ next unless defined $_;
+ $QUERY_PARAM{$_}=$self->{param}{$_};
+ }
+ $QUERY_CHARSET = $self->charset;
+ %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
+ %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
+}
+
+sub parse_params {
+ my($self,$tosplit) = @_;
+ my(@pairs) = split(/[&;]/,$tosplit);
+ my($param,$value);
+ for (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ next unless defined $param;
+ next if $NO_UNDEF_PARAMS and not defined $value;
+ $value = '' unless defined $value;
+ $param = unescape($param);
+ $value = unescape($value);
+ $self->add_parameter($param);
+ push (@{$self->{param}{$param}},$value);
+ }
+}
+
+sub add_parameter {
+ my($self,$param)=@_;
+ return unless defined $param;
+ push (@{$self->{'.parameters'}},$param)
+ unless defined($self->{param}{$param});
+}
+
+sub all_parameters {
+ my $self = shift;
+ return () unless defined($self) && $self->{'.parameters'};
+ return () unless @{$self->{'.parameters'}};
+ return @{$self->{'.parameters'}};
+}
+
+# put a filehandle into binary mode (DOS)
+sub binmode {
+ return unless defined($_[1]) && defined fileno($_[1]);
+ CORE::binmode($_[1]);
+}
+
+sub _make_tag_func {
+ my ($self,$tagname) = @_;
+ my $func = qq(
+ sub $tagname {
+ my (\$q,\$a,\@rest) = self_or_default(\@_);
+ my(\$attr) = '';
+ if (ref(\$a) && ref(\$a) eq 'HASH') {
+ my(\@attr) = make_attributes(\$a,\$q->{'escape'});
+ \$attr = " \@attr" if \@attr;
+ } else {
+ unshift \@rest,\$a if defined \$a;
+ }
+ );
+ if ($tagname=~/start_(\w+)/i) {
+ $func .= qq! return "<\L$1\E\$attr>";} !;
+ } elsif ($tagname=~/end_(\w+)/i) {
+ $func .= qq! return "<\L/$1\E>"; } !;
+ } else {
+ $func .= qq#
+ return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
+ my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
+ my \@result = map { "\$tag\$_\$untag" }
+ (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
+ return "\@result";
+ }#;
+ }
+return $func;
+}
+
+sub AUTOLOAD {
+ print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
+ my $func = &_compile;
+ goto &$func;
+}
+
+sub _compile {
+ my($func) = $AUTOLOAD;
+ my($pack,$func_name);
+ {
+ local($1,$2); # this fixes an obscure variable suicide problem.
+ $func=~/(.+)::([^:]+)$/;
+ ($pack,$func_name) = ($1,$2);
+ $pack=~s/::SUPER$//; # fix another obscure problem
+ $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
+ unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
+
+ my($sub) = \%{"$pack\:\:SUBS"};
+ unless (%$sub) {
+ my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ local ($@,$!);
+ eval "package $pack; $$auto";
+ croak("$AUTOLOAD: $@") if $@;
+ $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ (my $base = $func_name) =~ s/^(start_|end_)//i;
+ if ($EXPORT{':any'} ||
+ $EXPORT{'-any'} ||
+ $EXPORT{$base} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$base}) {
+ $code = $CGI::DefaultClass->_make_tag_func($func_name);
+ }
+ }
+ croak("Undefined subroutine $AUTOLOAD\n") unless $code;
+ local ($@,$!);
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ croak("$AUTOLOAD: $@");
+ }
+ }
+ CORE::delete($sub->{$func_name}); #free storage
+ return "$pack\:\:$func_name";
+}
+
+sub _selected {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq(selected="selected" ) : qq(selected );
+}
+
+sub _checked {
+ my $self = shift;
+ my $value = shift;
+ return '' unless $value;
+ return $XHTML ? qq(checked="checked" ) : qq(checked );
+}
+
+sub _reset_globals { initialize_globals(); }
+
+sub _setup_symbols {
+ my $self = shift;
+ my $compile = 0;
+
+ # to avoid reexporting unwanted variables
+ undef %EXPORT;
+
+ for (@_) {
+ $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
+ $NPH++, next if /^[:-]nph$/;
+ $NOSTICKY++, next if /^[:-]nosticky$/;
+ $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
+ $DEBUG=2, next if /^[:-][Dd]ebug$/;
+ $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+ $PARAM_UTF8++, next if /^[:-]utf8$/;
+ $XHTML++, next if /^[:-]xhtml$/;
+ $XHTML=0, next if /^[:-]no_?xhtml$/;
+ $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
+ $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $TABINDEX++, next if /^[:-]tabindex$/;
+ $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
+ $EXPORT{$_}++, next if /^[:-]any$/;
+ $compile++, next if /^[:-]compile$/;
+ $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
+
+ # This is probably extremely evil code -- to be deleted some day.
+ if (/^[-]autoload$/) {
+ my($pkg) = caller(1);
+ *{"${pkg}::AUTOLOAD"} = sub {
+ my($routine) = $AUTOLOAD;
+ $routine =~ s/^.*::/CGI::/;
+ &$routine;
+ };
+ next;
+ }
+
+ for (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
+ }
+ }
+ _compile_all(keys %EXPORT) if $compile;
+ @SAVED_SYMBOLS = @_;
+}
+
+sub charset {
+ my ($self,$charset) = self_or_default(@_);
+ $self->{'.charset'} = $charset if defined $charset;
+ $self->{'.charset'};
+}
+
+sub element_id {
+ my ($self,$new_value) = self_or_default(@_);
+ $self->{'.elid'} = $new_value if defined $new_value;
+ sprintf('%010d',$self->{'.elid'}++);
+}
+
+sub element_tab {
+ my ($self,$new_value) = self_or_default(@_);
+ $self->{'.etab'} ||= 1;
+ $self->{'.etab'} = $new_value if defined $new_value;
+ my $tab = $self->{'.etab'}++;
+ return '' unless $TABINDEX or defined $new_value;
+ return qq(tabindex="$tab" );
+}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+
+%SUBS = (
+
+'URL_ENCODED'=> <<'END_OF_FUNC',
+sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
+END_OF_FUNC
+
+'MULTIPART' => <<'END_OF_FUNC',
+sub MULTIPART { 'multipart/form-data'; }
+END_OF_FUNC
+
+'SERVER_PUSH' => <<'END_OF_FUNC',
+sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
+END_OF_FUNC
+
+'new_MultipartBuffer' => <<'END_OF_FUNC',
+# Create a new multipart buffer
+sub new_MultipartBuffer {
+ my($self,$boundary,$length) = @_;
+ return MultipartBuffer->new($self,$boundary,$length);
+}
+END_OF_FUNC
+
+'read_from_client' => <<'END_OF_FUNC',
+# Read data from a file handle
+sub read_from_client {
+ my($self, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return $MOD_PERL
+ ? $self->r->read($$buff, $len, $offset)
+ : read(\*STDIN, $$buff, $len, $offset);
+}
+END_OF_FUNC
+
+'read_from_stdin' => <<'END_OF_FUNC',
+# Read data from stdin until all is read
+sub read_from_stdin {
+ my($self, $buff) = @_;
+ local $^W=0; # prevent a warning
+
+ #
+ # TODO: loop over STDIN until all is read
+ #
+
+ my($eoffound) = 0;
+ my($localbuf) = '';
+ my($tempbuf) = '';
+ my($bufsiz) = 1024;
+ my($res);
+ while ($eoffound == 0) {
+ if ( $MOD_PERL ) {
+ $res = $self->r->read($tempbuf, $bufsiz, 0)
+ }
+ else {
+ $res = read(\*STDIN, $tempbuf, $bufsiz);
+ }
+
+ if ( !defined($res) ) {
+ # TODO: how to do error reporting ?
+ $eoffound = 1;
+ last;
+ }
+ if ( $res == 0 ) {
+ $eoffound = 1;
+ last;
+ }
+ $localbuf .= $tempbuf;
+ }
+
+ $$buff = $localbuf;
+
+ return $res;
+}
+END_OF_FUNC
+
+'delete' => <<'END_OF_FUNC',
+#### Method: delete
+# Deletes the named parameter entirely.
+####
+sub delete {
+ my($self,@p) = self_or_default(@_);
+ my(@names) = rearrange([NAME],@p);
+ my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
+ my %to_delete;
+ for my $name (@to_delete)
+ {
+ CORE::delete $self->{param}{$name};
+ CORE::delete $self->{'.fieldnames'}->{$name};
+ $to_delete{$name}++;
+ }
+ @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
+ return;
+}
+END_OF_FUNC
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+'import_names' => <<'END_OF_FUNC',
+sub import_names {
+ my($self,$namespace,$delete) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
+ if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
+ # can anyone find an easier way to do this?
+ for (keys %{"${namespace}::"}) {
+ local *symbol = "${namespace}::${_}";
+ undef $symbol;
+ undef @symbol;
+ undef %symbol;
+ }
+ }
+ my($param,@value,$var);
+ for $param ($self->param) {
+ # protect against silly names
+ ($var = $param)=~tr/a-zA-Z0-9_/_/c;
+ $var =~ s/^(?=\d)/_/;
+ local *symbol = "${namespace}::$var";
+ @value = $self->param($param);
+ @symbol = @value;
+ $symbol = $value[0];
+ }
+}
+END_OF_FUNC
+
+#### Method: keywords
+# Keywords acts a bit differently. Calling it in a list context
+# returns the list of keywords.
+# Calling it in a scalar context gives you the size of the list.
+####
+'keywords' => <<'END_OF_FUNC',
+sub keywords {
+ my($self,@values) = self_or_default(@_);
+ # If values is provided, then we set it.
+ $self->{param}{'keywords'}=[@values] if @values;
+ my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
+ @result;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
+'Vars' => <<'END_OF_FUNC',
+sub Vars {
+ my $q = shift;
+ my %in;
+ tie(%in,CGI,$q);
+ return %in if wantarray;
+ return \%in;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
+'ReadParse' => <<'END_OF_FUNC',
+sub ReadParse {
+ local(*in);
+ if (@_) {
+ *in = $_[0];
+ } else {
+ my $pkg = caller();
+ *in=*{"${pkg}::in"};
+ }
+ tie(%in,CGI);
+ return scalar(keys %in);
+}
+END_OF_FUNC
+
+'PrintHeader' => <<'END_OF_FUNC',
+sub PrintHeader {
+ my($self) = self_or_default(@_);
+ return $self->header();
+}
+END_OF_FUNC
+
+'HtmlTop' => <<'END_OF_FUNC',
+sub HtmlTop {
+ my($self,@p) = self_or_default(@_);
+ return $self->start_html(@p);
+}
+END_OF_FUNC
+
+'HtmlBot' => <<'END_OF_FUNC',
+sub HtmlBot {
+ my($self,@p) = self_or_default(@_);
+ return $self->end_html(@p);
+}
+END_OF_FUNC
+
+'SplitParam' => <<'END_OF_FUNC',
+sub SplitParam {
+ my ($param) = @_;
+ my (@params) = split ("\0", $param);
+ return (wantarray ? @params : $params[0]);
+}
+END_OF_FUNC
+
+'MethGet' => <<'END_OF_FUNC',
+sub MethGet {
+ return request_method() eq 'GET';
+}
+END_OF_FUNC
+
+'MethPost' => <<'END_OF_FUNC',
+sub MethPost {
+ return request_method() eq 'POST';
+}
+END_OF_FUNC
+
+'MethPut' => <<'END_OF_FUNC',
+sub MethPut {
+ return request_method() eq 'PUT';
+}
+END_OF_FUNC
+
+'TIEHASH' => <<'END_OF_FUNC',
+sub TIEHASH {
+ my $class = shift;
+ my $arg = $_[0];
+ if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
+ return $arg;
+ }
+ return $Q ||= $class->new(@_);
+}
+END_OF_FUNC
+
+'STORE' => <<'END_OF_FUNC',
+sub STORE {
+ my $self = shift;
+ my $tag = shift;
+ my $vals = shift;
+ my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
+ $self->param(-name=>$tag,-value=>\@vals);
+}
+END_OF_FUNC
+
+'FETCH' => <<'END_OF_FUNC',
+sub FETCH {
+ return $_[0] if $_[1] eq 'CGI';
+ return undef unless defined $_[0]->param($_[1]);
+ return join("\0",$_[0]->param($_[1]));
+}
+END_OF_FUNC
+
+'FIRSTKEY' => <<'END_OF_FUNC',
+sub FIRSTKEY {
+ $_[0]->{'.iterator'}=0;
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'NEXTKEY' => <<'END_OF_FUNC',
+sub NEXTKEY {
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'EXISTS' => <<'END_OF_FUNC',
+sub EXISTS {
+ exists $_[0]->{param}{$_[1]};
+}
+END_OF_FUNC
+
+'DELETE' => <<'END_OF_FUNC',
+sub DELETE {
+ $_[0]->delete($_[1]);
+}
+END_OF_FUNC
+
+'CLEAR' => <<'END_OF_FUNC',
+sub CLEAR {
+ %{$_[0]}=();
+}
+####
+END_OF_FUNC
+
+####
+# Append a new value to an existing query
+####
+'append' => <<'EOF',
+sub append {
+ my($self,@p) = self_or_default(@_);
+ my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
+ my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
+ if (@values) {
+ $self->add_parameter($name);
+ push(@{$self->{param}{$name}},@values);
+ }
+ return $self->param($name);
+}
+EOF
+
+#### Method: delete_all
+# Delete all parameters
+####
+'delete_all' => <<'EOF',
+sub delete_all {
+ my($self) = self_or_default(@_);
+ my @param = $self->param();
+ $self->delete(@param);
+}
+EOF
+
+'Delete' => <<'EOF',
+sub Delete {
+ my($self,@p) = self_or_default(@_);
+ $self->delete(@p);
+}
+EOF
+
+'Delete_all' => <<'EOF',
+sub Delete_all {
+ my($self,@p) = self_or_default(@_);
+ $self->delete_all(@p);
+}
+EOF
+
+#### Method: autoescape
+# If you want to turn off the autoescaping features,
+# call this method with undef as the argument
+'autoEscape' => <<'END_OF_FUNC',
+sub autoEscape {
+ my($self,$escape) = self_or_default(@_);
+ my $d = $self->{'escape'};
+ $self->{'escape'} = $escape;
+ $d;
+}
+END_OF_FUNC
+
+
+#### Method: version
+# Return the current version
+####
+'version' => <<'END_OF_FUNC',
+sub version {
+ return $VERSION;
+}
+END_OF_FUNC
+
+#### Method: url_param
+# Return a parameter in the QUERY_STRING, regardless of
+# whether this was a POST or a GET
+####
+'url_param' => <<'END_OF_FUNC',
+sub url_param {
+ my ($self,@p) = self_or_default(@_);
+ my $name = shift(@p);
+ return undef unless exists($ENV{QUERY_STRING});
+ unless (exists($self->{'.url_param'})) {
+ $self->{'.url_param'}={}; # empty hash
+ if ($ENV{QUERY_STRING} =~ /=/) {
+ my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
+ my($param,$value);
+ for (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ $param = unescape($param);
+ $value = unescape($value);
+ push(@{$self->{'.url_param'}->{$param}},$value);
+ }
+ } else {
+ my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING});
+ $self->{'.url_param'}{'keywords'} = \@keywords if @keywords;
+ }
+ }
+ return keys %{$self->{'.url_param'}} unless defined($name);
+ return () unless $self->{'.url_param'}->{$name};
+ return wantarray ? @{$self->{'.url_param'}->{$name}}
+ : $self->{'.url_param'}->{$name}->[0];
+}
+END_OF_FUNC
+
+#### Method: Dump
+# Returns a string in which all the known parameter/value
+# pairs are represented as nested lists, mainly for the purposes
+# of debugging.
+####
+'Dump' => <<'END_OF_FUNC',
+sub Dump {
+ my($self) = self_or_default(@_);
+ my($param,$value,@result);
+ return '<ul></ul>' unless $self->param;
+ push(@result,"<ul>");
+ for $param ($self->param) {
+ my($name)=$self->_maybe_escapeHTML($param);
+ push(@result,"<li><strong>$name</strong></li>");
+ push(@result,"<ul>");
+ for $value ($self->param($param)) {
+ $value = $self->_maybe_escapeHTML($value);
+ $value =~ s/\n/<br \/>\n/g;
+ push(@result,"<li>$value</li>");
+ }
+ push(@result,"</ul>");
+ }
+ push(@result,"</ul>");
+ return join("\n",@result);
+}
+END_OF_FUNC
+
+#### Method as_string
+#
+# synonym for "dump"
+####
+'as_string' => <<'END_OF_FUNC',
+sub as_string {
+ &Dump(@_);
+}
+END_OF_FUNC
+
+#### Method: save
+# Write values out to a filehandle in such a way that they can
+# be reinitialized by the filehandle form of the new() method
+####
+'save' => <<'END_OF_FUNC',
+sub save {
+ my($self,$filehandle) = self_or_default(@_);
+ $filehandle = to_filehandle($filehandle);
+ my($param);
+ local($,) = ''; # set print field separator back to a sane value
+ local($\) = ''; # set output line separator to a sane value
+ for $param ($self->param) {
+ my($escaped_param) = escape($param);
+ my($value);
+ for $value ($self->param($param)) {
+ print $filehandle "$escaped_param=",escape("$value"),"\n"
+ if length($escaped_param) or length($value);
+ }
+ }
+ for (keys %{$self->{'.fieldnames'}}) {
+ print $filehandle ".cgifields=",escape("$_"),"\n";
+ }
+ print $filehandle "=\n"; # end of record
+}
+END_OF_FUNC
+
+
+#### Method: save_parameters
+# An alias for save() that is a better name for exportation.
+# Only intended to be used with the function (non-OO) interface.
+####
+'save_parameters' => <<'END_OF_FUNC',
+sub save_parameters {
+ my $fh = shift;
+ return save(to_filehandle($fh));
+}
+END_OF_FUNC
+
+#### Method: restore_parameters
+# A way to restore CGI parameters from an initializer.
+# Only intended to be used with the function (non-OO) interface.
+####
+'restore_parameters' => <<'END_OF_FUNC',
+sub restore_parameters {
+ $Q = $CGI::DefaultClass->new(@_);
+}
+END_OF_FUNC
+
+#### Method: multipart_init
+# Return a Content-Type: style header for server-push
+# This has to be NPH on most web servers, and it is advisable to set $| = 1
+#
+# Many thanks to Ed Jordan <ed@fidalgo.net> for this
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
+####
+'multipart_init' => <<'END_OF_FUNC',
+sub multipart_init {
+ my($self,@p) = self_or_default(@_);
+ my($boundary,@other) = rearrange_header([BOUNDARY],@p);
+ if (!$boundary) {
+ $boundary = '------- =_';
+ my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z');
+ for (1..17) {
+ $boundary .= $chrs[rand(scalar @chrs)];
+ }
+ }
+
+ $self->{'separator'} = "$CRLF--$boundary$CRLF";
+ $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
+ $type = SERVER_PUSH($boundary);
+ return $self->header(
+ -nph => 0,
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_start
+# Return a Content-Type: style header for server-push, start of section
+#
+# Many thanks to Ed Jordan <ed@fidalgo.net> for this
+# contribution, updated by Andrew Benham (adsb@bigfoot.com)
+####
+'multipart_start' => <<'END_OF_FUNC',
+sub multipart_start {
+ my(@header);
+ my($self,@p) = self_or_default(@_);
+ my($type,@other) = rearrange([TYPE],@p);
+ $type = $type || 'text/html';
+ push(@header,"Content-Type: $type");
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ for (@other) {
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
+ }
+ push(@header,@other);
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ return $header;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_end
+# Return a MIME boundary separator for server-push, end of section
+#
+# Many thanks to Ed Jordan <ed@fidalgo.net> for this
+# contribution
+####
+'multipart_end' => <<'END_OF_FUNC',
+sub multipart_end {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'separator'};
+}
+END_OF_FUNC
+
+
+#### Method: multipart_final
+# Return a MIME boundary separator for server-push, end of all sections
+#
+# Contributed by Andrew Benham (adsb@bigfoot.com)
+####
+'multipart_final' => <<'END_OF_FUNC',
+sub multipart_final {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
+}
+END_OF_FUNC
+
+
+#### Method: header
+# Return a Content-Type: style header
+#
+####
+'header' => <<'END_OF_FUNC',
+sub header {
+ my($self,@p) = self_or_default(@_);
+ my(@header);
+
+ return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
+
+ my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
+ rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+ 'STATUS',['COOKIE','COOKIES'],'TARGET',
+ 'EXPIRES','NPH','CHARSET',
+ 'ATTACHMENT','P3P'],@p);
+
+ # CR escaping for values, per RFC 822
+ for my $header ($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
+ if (defined $header) {
+ # From RFC 822:
+ # Unfolding is accomplished by regarding CRLF immediately
+ # followed by a LWSP-char as equivalent to the LWSP-char.
+ $header =~ s/$CRLF(\s)/$1/g;
+
+ # All other uses of newlines are invalid input.
+ if ($header =~ m/$CRLF|\015|\012/) {
+ # shorten very long values in the diagnostic
+ $header = substr($header,0,72).'...' if (length $header > 72);
+ die "Invalid header value contains a newline not followed by whitespace: $header";
+ }
+ }
+ }
+
+ $nph ||= $NPH;
+
+ $type ||= 'text/html' unless defined($type);
+
+ if (defined $charset) {
+ $self->charset($charset);
+ } else {
+ $charset = $self->charset if $type =~ /^text\//;
+ }
+ $charset ||= '';
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ for (@other) {
+ # Don't use \s because of perl bug 21951
+ next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
+ ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
+ }
+
+ $type .= "; charset=$charset"
+ if $type ne ''
+ and $type !~ /\bcharset\b/
+ and defined $charset
+ and $charset ne '';
+
+ # Maybe future compatibility. Maybe not.
+ my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
+ push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
+ push(@header,"Server: " . &server_software()) if $nph;
+
+ push(@header,"Status: $status") if $status;
+ push(@header,"Window-Target: $target") if $target;
+ if ($p3p) {
+ $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
+ push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
+ }
+ # push all the cookies -- there may be several
+ if ($cookie) {
+ my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
+ for (@cookie) {
+ my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
+ push(@header,"Set-Cookie: $cs") if $cs ne '';
+ }
+ }
+ # if the user indicates an expiration time, then we need
+ # both an Expires and a Date header (so that the browser is
+ # uses OUR clock)
+ push(@header,"Expires: " . expires($expires,'http'))
+ if $expires;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
+ push(@header,"Pragma: no-cache") if $self->cache();
+ push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
+ push(@header,map {ucfirst $_} @other);
+ push(@header,"Content-Type: $type") if $type ne '';
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ if (($MOD_PERL >= 1) && !$nph) {
+ $self->r->send_cgi_header($header);
+ return '';
+ }
+ return $header;
+}
+END_OF_FUNC
+
+
+#### Method: cache
+# Control whether header() will produce the no-cache
+# Pragma directive.
+####
+'cache' => <<'END_OF_FUNC',
+sub cache {
+ my($self,$new_value) = self_or_default(@_);
+ $new_value = '' unless $new_value;
+ if ($new_value ne '') {
+ $self->{'cache'} = $new_value;
+ }
+ return $self->{'cache'};
+}
+END_OF_FUNC
+
+
+#### Method: redirect
+# Return a Location: style header
+#
+####
+'redirect' => <<'END_OF_FUNC',
+sub redirect {
+ my($self,@p) = self_or_default(@_);
+ my($url,$target,$status,$cookie,$nph,@other) =
+ rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
+ $status = '302 Found' unless defined $status;
+ $url ||= $self->self_url;
+ my(@o);
+ for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
+ unshift(@o,
+ '-Status' => $status,
+ '-Location'=> $url,
+ '-nph' => $nph);
+ unshift(@o,'-Target'=>$target) if $target;
+ unshift(@o,'-Type'=>'');
+ my @unescaped;
+ unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
+ return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
+}
+END_OF_FUNC
+
+
+#### Method: start_html
+# Canned HTML header
+#
+# Parameters:
+# $title -> (optional) The title for this HTML document (-title)
+# $author -> (optional) e-mail address of the author (-author)
+# $base -> (optional) if set to true, will enter the BASE address of this document
+# for resolving relative references (-base)
+# $xbase -> (optional) alternative base at some remote location (-xbase)
+# $target -> (optional) target window to load all links into (-target)
+# $script -> (option) Javascript code (-script)
+# $no_script -> (option) Javascript <noscript> tag (-noscript)
+# $meta -> (optional) Meta information tags
+# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
+# (a scalar or array ref)
+# $style -> (optional) reference to an external style sheet
+# @other -> (optional) any other named parameters you'd like to incorporate into
+# the <body> tag.
+####
+'start_html' => <<'END_OF_FUNC',
+sub start_html {
+ my($self,@p) = &self_or_default(@_);
+ my($title,$author,$base,$xbase,$script,$noscript,
+ $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
+ rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
+ META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
+
+ $self->element_id(0);
+ $self->element_tab(0);
+
+ $encoding = lc($self->charset) unless defined $encoding;
+
+ # Need to sort out the DTD before it's okay to call escapeHTML().
+ my(@result,$xml_dtd);
+ if ($dtd) {
+ if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
+ $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
+ } else {
+ $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
+ }
+ } else {
+ $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
+ }
+
+ $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
+ $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
+ push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
+
+ if (ref($dtd) && ref($dtd) eq 'ARRAY') {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
+ } else {
+ push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
+ $DTD_PUBLIC_IDENTIFIER = $dtd;
+ }
+
+ # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
+ # call escapeHTML(). Strangely enough, the title needs to be escaped as
+ # HTML while the author needs to be escaped as a URL.
+ $title = $self->_maybe_escapeHTML($title || 'Untitled Document');
+ $author = $self->escape($author);
+
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2|4\.01?)/i) {
+ $lang = "" unless defined $lang;
+ $XHTML = 0;
+ }
+ else {
+ $lang = 'en-US' unless defined $lang;
+ }
+
+ my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
+ my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
+ if $XHTML && $encoding && !$declare_xml;
+
+ push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
+ : ($lang ? qq(<html lang="$lang">) : "<html>")
+ . "<head><title>$title</title>");
+ if (defined $author) {
+ push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
+ : "<link rev=\"made\" href=\"mailto:$author\">");
+ }
+
+ if ($base || $xbase || $target) {
+ my $href = $xbase || $self->url('-path'=>1);
+ my $t = $target ? qq/ target="$target"/ : '';
+ push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
+ }
+
+ if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
+ for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
+ : qq(<meta name="$_" content="$meta->{$_}">)); }
+ }
+
+ my $meta_bits_set = 0;
+ if( $head ) {
+ if( ref $head ) {
+ push @result, @$head;
+ $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
+ }
+ else {
+ push @result, $head;
+ $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
+ }
+ }
+
+ # handle the infrequently-used -style and -script parameters
+ push(@result,$self->_style($style)) if defined $style;
+ push(@result,$self->_script($script)) if defined $script;
+ push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
+
+ # handle -noscript parameter
+ push(@result,<<END) if $noscript;
+<noscript>
+$noscript
+</noscript>
+END
+ ;
+ my($other) = @other ? " @other" : '';
+ push(@result,"</head>\n<body$other>\n");
+ return join("\n",@result);
+}
+END_OF_FUNC
+
+### Method: _style
+# internal method for generating a CSS style section
+####
+'_style' => <<'END_OF_FUNC',
+sub _style {
+ my ($self,$style) = @_;
+ my (@result);
+
+ my $type = 'text/css';
+ my $rel = 'stylesheet';
+
+
+ my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
+ my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
+
+ my @s = ref($style) eq 'ARRAY' ? @$style : $style;
+ my $other = '';
+
+ for my $s (@s) {
+ if (ref($s)) {
+ my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
+ rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
+ ('-foo'=>'bar',
+ ref($s) eq 'ARRAY' ? @$s : %$s));
+ my $type = defined $stype ? $stype : 'text/css';
+ my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
+ $other = "@other" if @other;
+
+ if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
+ { # If it is, push a LINK tag for each one
+ for $src (@$src)
+ {
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
+ }
+ }
+ else
+ { # Otherwise, push the single -src, if it exists.
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>)
+ ) if $src;
+ }
+ if ($verbatim) {
+ my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
+ push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
+ }
+ my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
+ push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
+
+ } else {
+ my $src = $s;
+ push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
+ : qq(<link rel="$rel" type="$type" href="$src"$other>));
+ }
+ }
+ @result;
+}
+END_OF_FUNC
+
+'_script' => <<'END_OF_FUNC',
+sub _script {
+ my ($self,$script) = @_;
+ my (@result);
+
+ my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
+ for $script (@scripts) {
+ my($src,$code,$language);
+ if (ref($script)) { # script is a hash
+ ($src,$code,$type) =
+ rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
+ '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ ref($script) eq 'ARRAY' ? @$script : %$script);
+ $type ||= 'text/javascript';
+ unless ($type =~ m!\w+/\w+!) {
+ $type =~ s/[\d.]+$//;
+ $type = "text/$type";
+ }
+ } else {
+ ($src,$code,$type) = ('',$script, 'text/javascript');
+ }
+
+ my $comment = '//'; # javascript by default
+ $comment = '#' if $type=~/perl|tcl/i;
+ $comment = "'" if $type=~/vbscript/i;
+
+ my ($cdata_start,$cdata_end);
+ if ($XHTML) {
+ $cdata_start = "$comment<![CDATA[\n";
+ $cdata_end .= "\n$comment]]>";
+ } else {
+ $cdata_start = "\n<!-- Hide script\n";
+ $cdata_end = $comment;
+ $cdata_end .= " End script hiding -->\n";
+ }
+ my(@satts);
+ push(@satts,'src'=>$src) if $src;
+ push(@satts,'type'=>$type);
+ $code = $cdata_start . $code . $cdata_end if defined $code;
+ push(@result,$self->script({@satts},$code || ''));
+ }
+ @result;
+}
+END_OF_FUNC
+
+#### Method: end_html
+# End an HTML document.
+# Trivial method for completeness. Just returns "</body>"
+####
+'end_html' => <<'END_OF_FUNC',
+sub end_html {
+ return "\n</body>\n</html>";
+}
+END_OF_FUNC
+
+
+################################
+# METHODS USED IN BUILDING FORMS
+################################
+
+#### Method: isindex
+# Just prints out the isindex tag.
+# Parameters:
+# $action -> optional URL of script to run
+# Returns:
+# A string containing a <isindex> tag
+'isindex' => <<'END_OF_FUNC',
+sub isindex {
+ my($self,@p) = self_or_default(@_);
+ my($action,@other) = rearrange([ACTION],@p);
+ $action = qq/ action="$action"/ if $action;
+ my($other) = @other ? " @other" : '';
+ return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
+}
+END_OF_FUNC
+
+
+#### Method: startform
+# This method is DEPRECATED
+# Start a form
+# Parameters:
+# $method -> optional submission method to use (GET or POST)
+# $action -> optional URL of script to run
+# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
+'startform' => <<'END_OF_FUNC',
+sub startform {
+ my($self,@p) = self_or_default(@_);
+
+ my($method,$action,$enctype,@other) =
+ rearrange([METHOD,ACTION,ENCTYPE],@p);
+
+ $method = $self->_maybe_escapeHTML(lc($method || 'post'));
+ $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
+ if (defined $action) {
+ $action = $self->_maybe_escapeHTML($action);
+ }
+ else {
+ $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
+ }
+ $action = qq(action="$action");
+ my($other) = @other ? " @other" : '';
+ $self->{'.parametersToAdd'}={};
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
+}
+END_OF_FUNC
+
+#### Method: start_form
+# Start a form
+# Parameters:
+# $method -> optional submission method to use (GET or POST)
+# $action -> optional URL of script to run
+# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
+'start_form' => <<'END_OF_FUNC',
+sub start_form {
+ my($self,@p) = self_or_default(@_);
+
+ my($method,$action,$enctype,@other) =
+ rearrange([METHOD,ACTION,ENCTYPE],@p);
+
+ $method = $self->_maybe_escapeHTML(lc($method || 'post'));
+
+ if( $XHTML ){
+ $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART);
+ }else{
+ $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED);
+ }
+
+ if (defined $action) {
+ $action = $self->_maybe_escapeHTML($action);
+ }
+ else {
+ $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url);
+ }
+ $action = qq(action="$action");
+ my($other) = @other ? " @other" : '';
+ $self->{'.parametersToAdd'}={};
+ return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
+}
+END_OF_FUNC
+
+#### Method: start_multipart_form
+'start_multipart_form' => <<'END_OF_FUNC',
+sub start_multipart_form {
+ my($self,@p) = self_or_default(@_);
+ if (defined($p[0]) && substr($p[0],0,1) eq '-') {
+ return $self->start_form(-enctype=>&MULTIPART,@p);
+ } else {
+ my($method,$action,@other) =
+ rearrange([METHOD,ACTION],@p);
+ return $self->start_form($method,$action,&MULTIPART,@other);
+ }
+}
+END_OF_FUNC
+
+
+
+#### Method: end_form
+# End a form
+'end_form' => <<'END_OF_FUNC',
+sub end_form {
+ my($self,@p) = self_or_default(@_);
+ if ( $NOSTICKY ) {
+ return wantarray ? ("</form>") : "\n</form>";
+ } else {
+ if (my @fields = $self->get_fields) {
+ return wantarray ? ("<div>",@fields,"</div>","</form>")
+ : "<div>".(join '',@fields)."</div>\n</form>";
+ } else {
+ return "</form>";
+ }
+ }
+}
+END_OF_FUNC
+
+#### Method: end_multipart_form
+# end a multipart form
+'end_multipart_form' => <<'END_OF_FUNC',
+sub end_multipart_form {
+ &end_form;
+}
+END_OF_FUNC
+
+
+'_textfield' => <<'END_OF_FUNC',
+sub _textfield {
+ my($self,$tag,@p) = self_or_default(@_);
+ my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
+
+ my $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : '';
+ $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ size="$size"/ : '';
+ my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
+ my($other) = @other ? " @other" : '';
+ # this entered at cristy's request to fix problems with file upload fields
+ # and WebTV -- not sure it won't break stuff
+ my($value) = $current ne '' ? qq(value="$current") : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
+ : qq(<input type="$tag" name="$name" $value$s$m$other>);
+}
+END_OF_FUNC
+
+#### Method: textfield
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <input type="text"> field
+#
+'textfield' => <<'END_OF_FUNC',
+sub textfield {
+ my($self,@p) = self_or_default(@_);
+ $self->_textfield('text',@p);
+}
+END_OF_FUNC
+
+
+#### Method: filefield
+# Parameters:
+# $name -> Name of the file upload field
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <input type="file"> field
+#
+'filefield' => <<'END_OF_FUNC',
+sub filefield {
+ my($self,@p) = self_or_default(@_);
+ $self->_textfield('file',@p);
+}
+END_OF_FUNC
+
+
+#### Method: password
+# Create a "secret password" entry field
+# Parameters:
+# $name -> Name of the field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characters.
+# $maxlength -> Optional maximum characters that can be entered.
+# Returns:
+# A string containing a <input type="password"> field
+#
+'password_field' => <<'END_OF_FUNC',
+sub password_field {
+ my ($self,@p) = self_or_default(@_);
+ $self->_textfield('password',@p);
+}
+END_OF_FUNC
+
+#### Method: textarea
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $rows -> Optional number of rows in text area
+# $columns -> Optional number of columns in text area
+# Returns:
+# A string containing a <textarea></textarea> tag
+#
+'textarea' => <<'END_OF_FUNC',
+sub textarea {
+ my($self,@p) = self_or_default(@_);
+ my($name,$default,$rows,$cols,$override,$tabindex,@other) =
+ rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
+
+ my($current)= $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->_maybe_escapeHTML($name) : '';
+ $current = defined($current) ? $self->_maybe_escapeHTML($current) : '';
+ my($r) = $rows ? qq/ rows="$rows"/ : '';
+ my($c) = $cols ? qq/ cols="$cols"/ : '';
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
+}
+END_OF_FUNC
+
+
+#### Method: button
+# Create a javascript button.
+# Parameters:
+# $name -> (optional) Name for the button. (-name)
+# $value -> (optional) Value of the button when selected (and visible name) (-value)
+# $onclick -> (optional) Text of the JavaScript to run when the button is
+# clicked.
+# Returns:
+# A string containing a <input type="button"> tag
+####
+'button' => <<'END_OF_FUNC',
+sub button {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
+ [ONCLICK,SCRIPT],TABINDEX],@p);
+
+ $label=$self->_maybe_escapeHTML($label);
+ $value=$self->_maybe_escapeHTML($value,1);
+ $script=$self->_maybe_escapeHTML($script);
+
+ $script ||= '';
+
+ my($name) = '';
+ $name = qq/ name="$label"/ if $label;
+ $value = $value || $label;
+ my($val) = '';
+ $val = qq/ value="$value"/ if $value;
+ $script = qq/ onclick="$script"/ if $script;
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
+ : qq(<input type="button"$name$val$script$other>);
+}
+END_OF_FUNC
+
+
+#### Method: submit
+# Create a "submit query" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# $value -> (optional) Value of the button when selected (also doubles as label).
+# $label -> (optional) Label printed on the button(also doubles as the value).
+# Returns:
+# A string containing a <input type="submit"> tag
+####
+'submit' => <<'END_OF_FUNC',
+sub submit {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
+
+ $label=$self->_maybe_escapeHTML($label);
+ $value=$self->_maybe_escapeHTML($value,1);
+
+ my $name = $NOSTICKY ? '' : 'name=".submit" ';
+ $name = qq/name="$label" / if defined($label);
+ $value = defined($value) ? $value : $label;
+ my $val = '';
+ $val = qq/value="$value" / if defined($value);
+ $tabindex = $self->element_tab($tabindex);
+ my($other) = @other ? "@other " : '';
+ return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
+ : qq(<input type="submit" $name$val$other>);
+}
+END_OF_FUNC
+
+
+#### Method: reset
+# Create a "reset" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <input type="reset"> tag
+####
+'reset' => <<'END_OF_FUNC',
+sub reset {
+ my($self,@p) = self_or_default(@_);
+ my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
+ $label=$self->_maybe_escapeHTML($label);
+ $value=$self->_maybe_escapeHTML($value,1);
+ my ($name) = ' name=".reset"';
+ $name = qq/ name="$label"/ if defined($label);
+ $value = defined($value) ? $value : $label;
+ my($val) = '';
+ $val = qq/ value="$value"/ if defined($value);
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
+ : qq(<input type="reset"$name$val$other>);
+}
+END_OF_FUNC
+
+
+#### Method: defaults
+# Create a "defaults" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <input type="submit" name=".defaults"> tag
+#
+# Note: this button has a special meaning to the initialization script,
+# and tells it to ERASE the current query string so that your defaults
+# are used again!
+####
+'defaults' => <<'END_OF_FUNC',
+sub defaults {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
+
+ $label=$self->_maybe_escapeHTML($label,1);
+ $label = $label || "Defaults";
+ my($value) = qq/ value="$label"/;
+ my($other) = @other ? " @other" : '';
+ $tabindex = $self->element_tab($tabindex);
+ return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
+ : qq/<input type="submit" NAME=".defaults"$value$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: comment
+# Create an HTML <!-- comment -->
+# Parameters: a string
+'comment' => <<'END_OF_FUNC',
+sub comment {
+ my($self,@p) = self_or_CGI(@_);
+ return "<!-- @p -->";
+}
+END_OF_FUNC
+
+#### Method: checkbox
+# Create a checkbox that is not logically linked to any others.
+# The field value is "on" when the button is checked.
+# Parameters:
+# $name -> Name of the checkbox
+# $checked -> (optional) turned on by default if true
+# $value -> (optional) value of the checkbox, 'on' by default
+# $label -> (optional) a user-readable label printed next to the box.
+# Otherwise the checkbox name is used.
+# Returns:
+# A string containing a <input type="checkbox"> field
+####
+'checkbox' => <<'END_OF_FUNC',
+sub checkbox {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
+ rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
+ [OVERRIDE,FORCE],TABINDEX],@p);
+
+ $value = defined $value ? $value : 'on';
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined $self->param($name))) {
+ $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
+ } else {
+ $checked = $self->_checked($checked);
+ }
+ my($the_label) = defined $label ? $label : $name;
+ $name = $self->_maybe_escapeHTML($name);
+ $value = $self->_maybe_escapeHTML($value,1);
+ $the_label = $self->_maybe_escapeHTML($the_label);
+ my($other) = @other ? "@other " : '';
+ $tabindex = $self->element_tab($tabindex);
+ $self->register_parameter($name);
+ return $XHTML ? CGI::label($labelattributes,
+ qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
+ : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
+}
+END_OF_FUNC
+
+
+
+# Escape HTML
+'escapeHTML' => <<'END_OF_FUNC',
+sub escapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ $toencode =~ s{&}{&amp;}gso;
+ $toencode =~ s{<}{&lt;}gso;
+ $toencode =~ s{>}{&gt;}gso;
+ if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
+ # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
+ # <http://validator.w3.org/docs/errors.html#bad-entity> /
+ # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
+ $toencode =~ s{"}{&#34;}gso;
+ }
+ else {
+ $toencode =~ s{"}{&quot;}gso;
+ }
+
+ # Handle bug in some browsers with Latin charsets
+ if ($self->{'.charset'}
+ && (uc($self->{'.charset'}) eq 'ISO-8859-1'
+ || uc($self->{'.charset'}) eq 'WINDOWS-1252')) {
+ $toencode =~ s{'}{&#39;}gso;
+ $toencode =~ s{\x8b}{&#8249;}gso;
+ $toencode =~ s{\x9b}{&#8250;}gso;
+ if (defined $newlinestoo && $newlinestoo) {
+ $toencode =~ s{\012}{&#10;}gso;
+ $toencode =~ s{\015}{&#13;}gso;
+ }
+ }
+ return $toencode;
+}
+END_OF_FUNC
+
+# unescape HTML -- used internally
+'unescapeHTML' => <<'END_OF_FUNC',
+sub unescapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$string) = CGI::self_or_default(@_);
+ return undef unless defined($string);
+ my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
+ : 1;
+ # thanks to Randal Schwartz for the correct solution to this one
+ $string=~ s[&(\S*?);]{
+ local $_ = $1;
+ /^amp$/i ? "&" :
+ /^quot$/i ? '"' :
+ /^gt$/i ? ">" :
+ /^lt$/i ? "<" :
+ /^#(\d+)$/ && $latin ? chr($1) :
+ /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
+ $_
+ }gex;
+ return $string;
+}
+END_OF_FUNC
+
+# Internal procedure - don't use
+'_tableize' => <<'END_OF_FUNC',
+sub _tableize {
+ my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ my @rowheaders = $rowheaders ? @$rowheaders : ();
+ my @colheaders = $colheaders ? @$colheaders : ();
+ my($result);
+
+ if (defined($columns)) {
+ $rows = int(0.99 + @elements/$columns) unless defined($rows);
+ }
+ if (defined($rows)) {
+ $columns = int(0.99 + @elements/$rows) unless defined($columns);
+ }
+
+ # rearrange into a pretty table
+ $result = "<table>";
+ my($row,$column);
+ unshift(@colheaders,'') if @colheaders && @rowheaders;
+ $result .= "<tr>" if @colheaders;
+ for (@colheaders) {
+ $result .= "<th>$_</th>";
+ }
+ for ($row=0;$row<$rows;$row++) {
+ $result .= "<tr>";
+ $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
+ for ($column=0;$column<$columns;$column++) {
+ $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
+ if defined($elements[$column*$rows + $row]);
+ }
+ $result .= "</tr>";
+ }
+ $result .= "</table>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: radio_group
+# Create a list of logically-linked radio buttons.
+# Parameters:
+# $name -> Common name for all the buttons.
+# $values -> A pointer to a regular array containing the
+# values for each button in the group.
+# $default -> (optional) Value of the button to turn on by default. Pass '-'
+# to turn _nothing_ on.
+# $linebreak -> (optional) Set to true to place linebreaks
+# between the buttons.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# An ARRAY containing a series of <input type="radio"> fields
+####
+'radio_group' => <<'END_OF_FUNC',
+sub radio_group {
+ my($self,@p) = self_or_default(@_);
+ $self->_box_group('radio',@p);
+}
+END_OF_FUNC
+
+#### Method: checkbox_group
+# Create a list of logically-linked checkboxes.
+# Parameters:
+# $name -> Common name for all the check boxes
+# $values -> A pointer to a regular array containing the
+# values for each checkbox in the group.
+# $defaults -> (optional)
+# 1. If a pointer to a regular array of checkbox values,
+# then this will be used to decide which
+# checkboxes to turn on by default.
+# 2. If a scalar, will be assumed to hold the
+# value of a single checkbox in the group to turn on.
+# $linebreak -> (optional) Set to true to place linebreaks
+# between the buttons.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# An ARRAY containing a series of <input type="checkbox"> fields
+####
+
+'checkbox_group' => <<'END_OF_FUNC',
+sub checkbox_group {
+ my($self,@p) = self_or_default(@_);
+ $self->_box_group('checkbox',@p);
+}
+END_OF_FUNC
+
+'_box_group' => <<'END_OF_FUNC',
+sub _box_group {
+ my $self = shift;
+ my $box_type = shift;
+
+ my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
+ $attributes,$rows,$columns,$rowheaders,$colheaders,
+ $override,$nolabels,$tabindex,$disabled,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
+ ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
+ [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
+ ],@_);
+
+
+ my($result,$checked,@elements,@values);
+
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+ my %checked = $self->previous_or_default($name,$defaults,$override);
+
+ # If no check array is specified, check the first by default
+ $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
+
+ $name=$self->_maybe_escapeHTML($name);
+
+ my %tabs = ();
+ if ($TABINDEX && $tabindex) {
+ if (!ref $tabindex) {
+ $self->element_tab($tabindex);
+ } elsif (ref $tabindex eq 'ARRAY') {
+ %tabs = map {$_=>$self->element_tab} @$tabindex;
+ } elsif (ref $tabindex eq 'HASH') {
+ %tabs = %$tabindex;
+ }
+ }
+ %tabs = map {$_=>$self->element_tab} @values unless %tabs;
+ my $other = @other ? "@other " : '';
+ my $radio_checked;
+
+ # for disabling groups of radio/checkbox buttons
+ my %disabled;
+ for (@{$disabled}) {
+ $disabled{$_}=1;
+ }
+
+ for (@values) {
+ my $disable="";
+ if ($disabled{$_}) {
+ $disable="disabled='1'";
+ }
+
+ my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
+ : $checked{$_});
+ my($break);
+ if ($linebreak) {
+ $break = $XHTML ? "<br />" : "<br>";
+ }
+ else {
+ $break = '';
+ }
+ my($label)='';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label = $self->_maybe_escapeHTML($label,1);
+ $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
+ }
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my $tab = $tabs{$_};
+ $_=$self->_maybe_escapeHTML($_);
+
+ if ($XHTML) {
+ push @elements,
+ CGI::label($labelattributes,
+ qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
+ } else {
+ push(@elements,qq/<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable>${label}${break}/);
+ }
+ }
+ $self->register_parameter($name);
+ return wantarray ? @elements : "@elements"
+ unless defined($columns) || defined($rows);
+ return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
+}
+END_OF_FUNC
+
+
+#### Method: popup_menu
+# Create a popup menu.
+# Parameters:
+# $name -> Name for all the menu
+# $values -> A pointer to a regular array containing the
+# text of each menu item.
+# $default -> (optional) Default item to display
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# A string containing the definition of a popup menu.
+####
+'popup_menu' => <<'END_OF_FUNC',
+sub popup_menu {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
+ rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
+ ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
+ my($result,%selected);
+
+ if (!$override && defined($self->param($name))) {
+ $selected{$self->param($name)}++;
+ } elsif (defined $default) {
+ %selected = map {$_=>1} ref($default) eq 'ARRAY'
+ ? @$default
+ : $default;
+ }
+ $name=$self->_maybe_escapeHTML($name);
+ my($other) = @other ? " @other" : '';
+
+ my(@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+ $tabindex = $self->element_tab($tabindex);
+ $name = q{} if ! defined $name;
+ $result = qq/<select name="$name" $tabindex$other>\n/;
+ for (@values) {
+ if (/<optgroup/) {
+ for my $v (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ for my $selected (keys %selected) {
+ $v =~ s/(value="\Q$selected\E")/$selectit $1/;
+ }
+ $result .= "$v\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = $self->_selected($selected{$_});
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->_maybe_escapeHTML($_);
+ $label = $self->_maybe_escapeHTML($label,1);
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
+ }
+ }
+
+ $result .= "</select>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: optgroup
+# Create a optgroup.
+# Parameters:
+# $name -> Label for the group
+# $values -> A pointer to a regular array containing the
+# values for each option line in the group.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each item
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# $labeled -> (optional)
+# A true value indicates the value should be used as the label attribute
+# in the option elements.
+# The label attribute specifies the option label presented to the user.
+# This defaults to the content of the <option> element, but the label
+# attribute allows authors to more easily use optgroup without sacrificing
+# compatibility with browsers that do not support option groups.
+# $novals -> (optional)
+# A true value indicates to suppress the val attribute in the option elements
+# Returns:
+# A string containing the definition of an option group.
+####
+'optgroup' => <<'END_OF_FUNC',
+sub optgroup {
+ my($self,@p) = self_or_default(@_);
+ my($name,$values,$attributes,$labeled,$noval,$labels,@other)
+ = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
+
+ my($result,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
+ my($other) = @other ? " @other" : '';
+
+ $name = $self->_maybe_escapeHTML($name) || q{};
+ $result = qq/<optgroup label="$name"$other>\n/;
+ for (@values) {
+ if (/<optgroup/) {
+ for (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ s/(value="$selected")/$selectit $1/ if defined $selected;
+ $result .= "$_\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label=$self->_maybe_escapeHTML($label);
+ my($value)=$self->_maybe_escapeHTML($_,1);
+ $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
+ : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
+ : $novals ? "<option$attribs>$label</option>\n"
+ : "<option$attribs value=\"$value\">$label</option>\n";
+ }
+ }
+ $result .= "</optgroup>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: scrolling_list
+# Create a scrolling list.
+# Parameters:
+# $name -> name for the list
+# $values -> A pointer to a regular array containing the
+# values for each option line in the list.
+# $defaults -> (optional)
+# 1. If a pointer to a regular array of options,
+# then this will be used to decide which
+# lines to turn on by default.
+# 2. Otherwise holds the value of the single line to turn on.
+# $size -> (optional) Size of the list.
+# $multiple -> (optional) If set, allow multiple selections.
+# $labels -> (optional)
+# A pointer to a hash of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# A string containing the definition of a scrolling list.
+####
+'scrolling_list' => <<'END_OF_FUNC',
+sub scrolling_list {
+ my($self,@p) = self_or_default(@_);
+ my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
+ = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
+
+ my($result,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
+ $size = $size || scalar(@values);
+
+ my(%selected) = $self->previous_or_default($name,$defaults,$override);
+
+ my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
+ my($has_size) = $size ? qq/ size="$size"/: '';
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->_maybe_escapeHTML($name);
+ $tabindex = $self->element_tab($tabindex);
+ $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
+ for (@values) {
+ if (/<optgroup/) {
+ for my $v (split(/\n/)) {
+ my $selectit = $XHTML ? 'selected="selected"' : 'selected';
+ for my $selected (keys %selected) {
+ $v =~ s/(value="$selected")/$selectit $1/;
+ }
+ $result .= "$v\n";
+ }
+ }
+ else {
+ my $attribs = $self->_set_attributes($_, $attributes);
+ my($selectit) = $self->_selected($selected{$_});
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->_maybe_escapeHTML($_);
+ $label = $self->_maybe_escapeHTML($label,1);
+ $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
+ }
+ }
+
+ $result .= "</select>";
+ $self->register_parameter($name);
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: hidden
+# Parameters:
+# $name -> Name of the hidden field
+# @default -> (optional) Initial values of field (may be an array)
+# or
+# $default->[initial values of field]
+# Returns:
+# A string containing a <input type="hidden" name="name" value="value">
+####
+'hidden' => <<'END_OF_FUNC',
+sub hidden {
+ my($self,@p) = self_or_default(@_);
+
+ # this is the one place where we departed from our standard
+ # calling scheme, so we have to special-case (darn)
+ my(@result,@value);
+ my($name,$default,$override,@other) =
+ rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
+
+ my $do_override = 0;
+ if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
+ @value = ref($default) ? @{$default} : $default;
+ $do_override = $override;
+ } else {
+ for ($default,$override,@other) {
+ push(@value,$_) if defined($_);
+ }
+ undef @other;
+ }
+
+ # use previous values if override is not set
+ my @prev = $self->param($name);
+ @value = @prev if !$do_override && @prev;
+
+ $name=$self->_maybe_escapeHTML($name);
+ for (@value) {
+ $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : '';
+ push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
+ : qq(<input type="hidden" name="$name" value="$_" @other>);
+ }
+ return wantarray ? @result : join('',@result);
+}
+END_OF_FUNC
+
+
+#### Method: image_button
+# Parameters:
+# $name -> Name of the button
+# $src -> URL of the image source
+# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
+# Returns:
+# A string containing a <input type="image" name="name" src="url" align="alignment">
+####
+'image_button' => <<'END_OF_FUNC',
+sub image_button {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$src,$alignment,@other) =
+ rearrange([NAME,SRC,ALIGN],@p);
+
+ my($align) = $alignment ? " align=\L\"$alignment\"" : '';
+ my($other) = @other ? " @other" : '';
+ $name=$self->_maybe_escapeHTML($name);
+ return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
+ : qq/<input type="image" name="$name" src="$src"$align$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: self_url
+# Returns a URL containing the current script and all its
+# param/value pairs arranged as a query. You can use this
+# to create a link that, when selected, will reinvoke the
+# script with all its state information preserved.
+####
+'self_url' => <<'END_OF_FUNC',
+sub self_url {
+ my($self,@p) = self_or_default(@_);
+ return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
+}
+END_OF_FUNC
+
+
+# This is provided as a synonym to self_url() for people unfortunate
+# enough to have incorporated it into their programs already!
+'state' => <<'END_OF_FUNC',
+sub state {
+ &self_url;
+}
+END_OF_FUNC
+
+
+#### Method: url
+# Like self_url, but doesn't return the query string part of
+# the URL.
+####
+'url' => <<'END_OF_FUNC',
+sub url {
+ my($self,@p) = self_or_default(@_);
+ my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
+ rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
+ my $url = '';
+ $full++ if $base || !($relative || $absolute);
+ $rewrite++ unless defined $rewrite;
+
+ my $path = $self->path_info;
+ my $script_name = $self->script_name;
+ my $request_uri = unescape($self->request_uri) || '';
+ my $query_str = $self->query_string;
+
+ my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
+ undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
+
+ my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
+ $uri =~ s/\?.*$//s; # remove query string
+ $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
+# $uri =~ s/\Q$path\E$// if defined $path; # remove path
+
+ if ($full) {
+ my $protocol = $self->protocol();
+ $url = "$protocol://";
+ my $vh = http('x_forwarded_host') || http('host') || '';
+ $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
+
+ $url .= $vh || server_name();
+
+ my $port = $self->virtual_port;
+
+ # add the port to the url unless it's the protocol's default port
+ $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80)
+ or (lc($protocol) eq 'https' && $port == 443);
+
+ return $url if $base;
+
+ $url .= $uri;
+ } elsif ($relative) {
+ ($url) = $uri =~ m!([^/]+)$!;
+ } elsif ($absolute) {
+ $url = $uri;
+ }
+
+ $url .= $path if $path_info and defined $path;
+ $url .= "?$query_str" if $query and $query_str ne '';
+ $url ||= '';
+ $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
+ return $url;
+}
+
+END_OF_FUNC
+
+#### Method: cookie
+# Set or read a cookie from the specified name.
+# Cookie can then be passed to header().
+# Usual rules apply to the stickiness of -value.
+# Parameters:
+# -name -> name for this cookie (optional)
+# -value -> value of this cookie (scalar, array or hash)
+# -path -> paths for which this cookie is valid (optional)
+# -domain -> internet domain in which this cookie is valid (optional)
+# -secure -> if true, cookie only passed through secure channel (optional)
+# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
+####
+'cookie' => <<'END_OF_FUNC',
+sub cookie {
+ my($self,@p) = self_or_default(@_);
+ my($name,$value,$path,$domain,$secure,$expires,$httponly) =
+ rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
+
+ require CGI::Cookie;
+
+ # if no value is supplied, then we retrieve the
+ # value of the cookie, if any. For efficiency, we cache the parsed
+ # cookies in our state variables.
+ unless ( defined($value) ) {
+ $self->{'.cookies'} = CGI::Cookie->fetch;
+
+ # If no name is supplied, then retrieve the names of all our cookies.
+ return () unless $self->{'.cookies'};
+ return keys %{$self->{'.cookies'}} unless $name;
+ return () unless $self->{'.cookies'}->{$name};
+ return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
+ }
+
+ # If we get here, we're creating a new cookie
+ return undef unless defined($name) && $name ne ''; # this is an error
+
+ my @param;
+ push(@param,'-name'=>$name);
+ push(@param,'-value'=>$value);
+ push(@param,'-domain'=>$domain) if $domain;
+ push(@param,'-path'=>$path) if $path;
+ push(@param,'-expires'=>$expires) if $expires;
+ push(@param,'-secure'=>$secure) if $secure;
+ push(@param,'-httponly'=>$httponly) if $httponly;
+
+ return CGI::Cookie->new(@param);
+}
+END_OF_FUNC
+
+'parse_keywordlist' => <<'END_OF_FUNC',
+sub parse_keywordlist {
+ my($self,$tosplit) = @_;
+ $tosplit = unescape($tosplit); # unescape the keywords
+ $tosplit=~tr/+/ /; # pluses to spaces
+ my(@keywords) = split(/\s+/,$tosplit);
+ return @keywords;
+}
+END_OF_FUNC
+
+'param_fetch' => <<'END_OF_FUNC',
+sub param_fetch {
+ my($self,@p) = self_or_default(@_);
+ my($name) = rearrange([NAME],@p);
+ unless (exists($self->{param}{$name})) {
+ $self->add_parameter($name);
+ $self->{param}{$name} = [];
+ }
+
+ return $self->{param}{$name};
+}
+END_OF_FUNC
+
+###############################################
+# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
+###############################################
+
+#### Method: path_info
+# Return the extra virtual path information provided
+# after the URL (if any)
+####
+'path_info' => <<'END_OF_FUNC',
+sub path_info {
+ my ($self,$info) = self_or_default(@_);
+ if (defined($info)) {
+ $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
+ $self->{'.path_info'} = $info;
+ } elsif (! defined($self->{'.path_info'}) ) {
+ my (undef,$path_info) = $self->_name_and_path_from_env;
+ $self->{'.path_info'} = $path_info || '';
+ }
+ return $self->{'.path_info'};
+}
+END_OF_FUNC
+
+# This function returns a potentially modified version of SCRIPT_NAME
+# and PATH_INFO. Some HTTP servers do sanitise the paths in those
+# variables. It is the case of at least Apache 2. If for instance the
+# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
+# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
+# SCRIPT_NAME=/path/to/env.cgi
+# PATH_INFO=/x/y/x
+#
+# This is all fine except that some bogus CGI scripts expect
+# PATH_INFO=/http://foo when the user requests
+# http://xxx/script.cgi/http://foo
+#
+# Old versions of this module used to accomodate with those scripts, so
+# this is why we do this here to keep those scripts backward compatible.
+# Basically, we accomodate with those scripts but within limits, that is
+# we only try to preserve the number of / that were provided by the user
+# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
+# of consecutive /.
+#
+# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
+# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
+# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
+# possibly sanitised by the HTTP server, so in the case of Apache 2:
+# script_name == /foo/x/z/script.cgi and path_info == /b/c.
+#
+# Future versions of this module may no longer do that, so one should
+# avoid relying on the browser, proxy, server, and CGI.pm preserving the
+# number of consecutive slashes as no guarantee can be made there.
+'_name_and_path_from_env' => <<'END_OF_FUNC',
+sub _name_and_path_from_env {
+ my $self = shift;
+ my $script_name = $ENV{SCRIPT_NAME} || '';
+ my $path_info = $ENV{PATH_INFO} || '';
+ my $uri = $self->request_uri || '';
+
+ $uri =~ s/\?.*//s;
+ $uri = unescape($uri);
+
+ if ($uri ne "$script_name$path_info") {
+ my $script_name_pattern = quotemeta($script_name);
+ my $path_info_pattern = quotemeta($path_info);
+ $script_name_pattern =~ s{(?:\\/)+}{/+}g;
+ $path_info_pattern =~ s{(?:\\/)+}{/+}g;
+
+ if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
+ # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
+ # numer of consecutive slashes, so we can extract the info from
+ # REQUEST_URI:
+ ($script_name, $path_info) = ($1, $2);
+ }
+ }
+ return ($script_name,$path_info);
+}
+END_OF_FUNC
+
+
+#### Method: request_method
+# Returns 'POST', 'GET', 'PUT' or 'HEAD'
+####
+'request_method' => <<'END_OF_FUNC',
+sub request_method {
+ return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef;
+}
+END_OF_FUNC
+
+#### Method: content_type
+# Returns the content_type string
+####
+'content_type' => <<'END_OF_FUNC',
+sub content_type {
+ return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef;
+}
+END_OF_FUNC
+
+#### Method: path_translated
+# Return the physical path information provided
+# by the URL (if any)
+####
+'path_translated' => <<'END_OF_FUNC',
+sub path_translated {
+ return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef;
+}
+END_OF_FUNC
+
+
+#### Method: request_uri
+# Return the literal request URI
+####
+'request_uri' => <<'END_OF_FUNC',
+sub request_uri {
+ return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef;
+}
+END_OF_FUNC
+
+
+#### Method: query_string
+# Synthesize a query string from our current
+# parameters
+####
+'query_string' => <<'END_OF_FUNC',
+sub query_string {
+ my($self) = self_or_default(@_);
+ my($param,$value,@pairs);
+ for $param ($self->param) {
+ my($eparam) = escape($param);
+ for $value ($self->param($param)) {
+ $value = escape($value);
+ next unless defined $value;
+ push(@pairs,"$eparam=$value");
+ }
+ }
+ for (keys %{$self->{'.fieldnames'}}) {
+ push(@pairs,".cgifields=".escape("$_"));
+ }
+ return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
+}
+END_OF_FUNC
+
+
+#### Method: accept
+# Without parameters, returns an array of the
+# MIME types the browser accepts.
+# With a single parameter equal to a MIME
+# type, will return undef if the browser won't
+# accept it, 1 if the browser accepts it but
+# doesn't give a preference, or a floating point
+# value between 0.0 and 1.0 if the browser
+# declares a quantitative score for it.
+# This handles MIME type globs correctly.
+####
+'Accept' => <<'END_OF_FUNC',
+sub Accept {
+ my($self,$search) = self_or_CGI(@_);
+ my(%prefs,$type,$pref,$pat);
+
+ my(@accept) = defined $self->http('accept')
+ ? split(',',$self->http('accept'))
+ : ();
+
+ for (@accept) {
+ ($pref) = /q=(\d\.\d+|\d+)/;
+ ($type) = m#(\S+/[^;]+)#;
+ next unless $type;
+ $prefs{$type}=$pref || 1;
+ }
+
+ return keys %prefs unless $search;
+
+ # if a search type is provided, we may need to
+ # perform a pattern matching operation.
+ # The MIME types use a glob mechanism, which
+ # is easily translated into a perl pattern match
+
+ # First return the preference for directly supported
+ # types:
+ return $prefs{$search} if $prefs{$search};
+
+ # Didn't get it, so try pattern matching.
+ for (keys %prefs) {
+ next unless /\*/; # not a pattern match
+ ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
+ $pat =~ s/\*/.*/g; # turn it into a pattern
+ return $prefs{$_} if $search=~/$pat/;
+ }
+}
+END_OF_FUNC
+
+
+#### Method: user_agent
+# If called with no parameters, returns the user agent.
+# If called with one parameter, does a pattern match (case
+# insensitive) on the user agent.
+####
+'user_agent' => <<'END_OF_FUNC',
+sub user_agent {
+ my($self,$match)=self_or_CGI(@_);
+ my $user_agent = $self->http('user_agent');
+ return $user_agent unless $match && $user_agent;
+ return $user_agent =~ /$match/i;
+}
+END_OF_FUNC
+
+
+#### Method: raw_cookie
+# Returns the magic cookies for the session.
+# The cookies are not parsed or altered in any way, i.e.
+# cookies are returned exactly as given in the HTTP
+# headers. If a cookie name is given, only that cookie's
+# value is returned, otherwise the entire raw cookie
+# is returned.
+####
+'raw_cookie' => <<'END_OF_FUNC',
+sub raw_cookie {
+ my($self,$key) = self_or_CGI(@_);
+
+ require CGI::Cookie;
+
+ if (defined($key)) {
+ $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
+ unless $self->{'.raw_cookies'};
+
+ return () unless $self->{'.raw_cookies'};
+ return () unless $self->{'.raw_cookies'}->{$key};
+ return $self->{'.raw_cookies'}->{$key};
+ }
+ return $self->http('cookie') || $ENV{'COOKIE'} || '';
+}
+END_OF_FUNC
+
+#### Method: virtual_host
+# Return the name of the virtual_host, which
+# is not always the same as the server
+######
+'virtual_host' => <<'END_OF_FUNC',
+sub virtual_host {
+ my $vh = http('x_forwarded_host') || http('host') || server_name();
+ $vh =~ s/:\d+$//; # get rid of port number
+ return $vh;
+}
+END_OF_FUNC
+
+#### Method: remote_host
+# Return the name of the remote host, or its IP
+# address if unavailable. If this variable isn't
+# defined, it returns "localhost" for debugging
+# purposes.
+####
+'remote_host' => <<'END_OF_FUNC',
+sub remote_host {
+ return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
+ || 'localhost';
+}
+END_OF_FUNC
+
+
+#### Method: remote_addr
+# Return the IP addr of the remote host.
+####
+'remote_addr' => <<'END_OF_FUNC',
+sub remote_addr {
+ return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
+}
+END_OF_FUNC
+
+
+#### Method: script_name
+# Return the partial URL to this script for
+# self-referencing scripts. Also see
+# self_url(), which returns a URL with all state information
+# preserved.
+####
+'script_name' => <<'END_OF_FUNC',
+sub script_name {
+ my ($self,@p) = self_or_default(@_);
+ if (@p) {
+ $self->{'.script_name'} = shift @p;
+ } elsif (!exists $self->{'.script_name'}) {
+ my ($script_name,$path_info) = $self->_name_and_path_from_env();
+ $self->{'.script_name'} = $script_name;
+ }
+ return $self->{'.script_name'};
+}
+END_OF_FUNC
+
+
+#### Method: referer
+# Return the HTTP_REFERER: useful for generating
+# a GO BACK button.
+####
+'referer' => <<'END_OF_FUNC',
+sub referer {
+ my($self) = self_or_CGI(@_);
+ return $self->http('referer');
+}
+END_OF_FUNC
+
+
+#### Method: server_name
+# Return the name of the server
+####
+'server_name' => <<'END_OF_FUNC',
+sub server_name {
+ return $ENV{'SERVER_NAME'} || 'localhost';
+}
+END_OF_FUNC
+
+#### Method: server_software
+# Return the name of the server software
+####
+'server_software' => <<'END_OF_FUNC',
+sub server_software {
+ return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
+}
+END_OF_FUNC
+
+#### Method: virtual_port
+# Return the server port, taking virtual hosts into account
+####
+'virtual_port' => <<'END_OF_FUNC',
+sub virtual_port {
+ my($self) = self_or_default(@_);
+ my $vh = $self->http('x_forwarded_host') || $self->http('host');
+ my $protocol = $self->protocol;
+ if ($vh) {
+ return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
+ } else {
+ return $self->server_port();
+ }
+}
+END_OF_FUNC
+
+#### Method: server_port
+# Return the tcp/ip port the server is running on
+####
+'server_port' => <<'END_OF_FUNC',
+sub server_port {
+ return $ENV{'SERVER_PORT'} || 80; # for debugging
+}
+END_OF_FUNC
+
+#### Method: server_protocol
+# Return the protocol (usually HTTP/1.0)
+####
+'server_protocol' => <<'END_OF_FUNC',
+sub server_protocol {
+ return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
+}
+END_OF_FUNC
+
+#### Method: http
+# Return the value of an HTTP variable, or
+# the list of variables if none provided
+####
+'http' => <<'END_OF_FUNC',
+sub http {
+ my ($self,$parameter) = self_or_CGI(@_);
+ if ( defined($parameter) ) {
+ $parameter =~ tr/-a-z/_A-Z/;
+ if ( $parameter =~ /^HTTP(?:_|$)/ ) {
+ return $ENV{$parameter};
+ }
+ return $ENV{"HTTP_$parameter"};
+ }
+ return grep { /^HTTP(?:_|$)/ } keys %ENV;
+}
+END_OF_FUNC
+
+#### Method: https
+# Return the value of HTTPS, or
+# the value of an HTTPS variable, or
+# the list of variables
+####
+'https' => <<'END_OF_FUNC',
+sub https {
+ my ($self,$parameter) = self_or_CGI(@_);
+ if ( defined($parameter) ) {
+ $parameter =~ tr/-a-z/_A-Z/;
+ if ( $parameter =~ /^HTTPS(?:_|$)/ ) {
+ return $ENV{$parameter};
+ }
+ return $ENV{"HTTPS_$parameter"};
+ }
+ return wantarray
+ ? grep { /^HTTPS(?:_|$)/ } keys %ENV
+ : $ENV{'HTTPS'};
+}
+END_OF_FUNC
+
+#### Method: protocol
+# Return the protocol (http or https currently)
+####
+'protocol' => <<'END_OF_FUNC',
+sub protocol {
+ local($^W)=0;
+ my $self = shift;
+ return 'https' if uc($self->https()) eq 'ON';
+ return 'https' if $self->server_port == 443;
+ my $prot = $self->server_protocol;
+ my($protocol,$version) = split('/',$prot);
+ return "\L$protocol\E";
+}
+END_OF_FUNC
+
+#### Method: remote_ident
+# Return the identity of the remote user
+# (but only if his host is running identd)
+####
+'remote_ident' => <<'END_OF_FUNC',
+sub remote_ident {
+ return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef;
+}
+END_OF_FUNC
+
+
+#### Method: auth_type
+# Return the type of use verification/authorization in use, if any.
+####
+'auth_type' => <<'END_OF_FUNC',
+sub auth_type {
+ return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef;
+}
+END_OF_FUNC
+
+
+#### Method: remote_user
+# Return the authorization name used for user
+# verification.
+####
+'remote_user' => <<'END_OF_FUNC',
+sub remote_user {
+ return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef;
+}
+END_OF_FUNC
+
+
+#### Method: user_name
+# Try to return the remote user's name by hook or by
+# crook
+####
+'user_name' => <<'END_OF_FUNC',
+sub user_name {
+ my ($self) = self_or_CGI(@_);
+ return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+#### Method: nosticky
+# Set or return the NOSTICKY global flag
+####
+'nosticky' => <<'END_OF_FUNC',
+sub nosticky {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NOSTICKY = $param if defined($param);
+ return $CGI::NOSTICKY;
+}
+END_OF_FUNC
+
+#### Method: nph
+# Set or return the NPH global flag
+####
+'nph' => <<'END_OF_FUNC',
+sub nph {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NPH = $param if defined($param);
+ return $CGI::NPH;
+}
+END_OF_FUNC
+
+#### Method: private_tempfiles
+# Set or return the private_tempfiles global flag
+####
+'private_tempfiles' => <<'END_OF_FUNC',
+sub private_tempfiles {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::PRIVATE_TEMPFILES = $param if defined($param);
+ return $CGI::PRIVATE_TEMPFILES;
+}
+END_OF_FUNC
+#### Method: close_upload_files
+# Set or return the close_upload_files global flag
+####
+'close_upload_files' => <<'END_OF_FUNC',
+sub close_upload_files {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
+ return $CGI::CLOSE_UPLOAD_FILES;
+}
+END_OF_FUNC
+
+
+#### Method: default_dtd
+# Set or return the default_dtd global
+####
+'default_dtd' => <<'END_OF_FUNC',
+sub default_dtd {
+ my ($self,$param,$param2) = self_or_CGI(@_);
+ if (defined $param2 && defined $param) {
+ $CGI::DEFAULT_DTD = [ $param, $param2 ];
+ } elsif (defined $param) {
+ $CGI::DEFAULT_DTD = $param;
+ }
+ return $CGI::DEFAULT_DTD;
+}
+END_OF_FUNC
+
+# -------------- really private subroutines -----------------
+'_maybe_escapeHTML' => <<'END_OF_FUNC',
+sub _maybe_escapeHTML {
+ # hack to work around earlier hacks
+ push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
+ my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && !$self->{'escape'};
+ return $self->escapeHTML($toencode, $newlinestoo);
+}
+END_OF_FUNC
+
+'previous_or_default' => <<'END_OF_FUNC',
+sub previous_or_default {
+ my($self,$name,$defaults,$override) = @_;
+ my(%selected);
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined($self->param($name)) ) ) {
+ $selected{$_}++ for $self->param($name);
+ } elsif (defined($defaults) && ref($defaults) &&
+ (ref($defaults) eq 'ARRAY')) {
+ $selected{$_}++ for @{$defaults};
+ } else {
+ $selected{$defaults}++ if defined($defaults);
+ }
+
+ return %selected;
+}
+END_OF_FUNC
+
+'register_parameter' => <<'END_OF_FUNC',
+sub register_parameter {
+ my($self,$param) = @_;
+ $self->{'.parametersToAdd'}->{$param}++;
+}
+END_OF_FUNC
+
+'get_fields' => <<'END_OF_FUNC',
+sub get_fields {
+ my($self) = @_;
+ return $self->CGI::hidden('-name'=>'.cgifields',
+ '-values'=>[keys %{$self->{'.parametersToAdd'}}],
+ '-override'=>1);
+}
+END_OF_FUNC
+
+'read_from_cmdline' => <<'END_OF_FUNC',
+sub read_from_cmdline {
+ my($input,@words);
+ my($query_string);
+ my($subpath);
+ if ($DEBUG && @ARGV) {
+ @words = @ARGV;
+ } elsif ($DEBUG > 1) {
+ require "shellwords.pl";
+ print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
+ chomp(@lines = <STDIN>); # remove newlines
+ $input = join(" ",@lines);
+ @words = &shellwords($input);
+ }
+ for (@words) {
+ s/\\=/%3D/g;
+ s/\\&/%26/g;
+ }
+
+ if ("@words"=~/=/) {
+ $query_string = join('&',@words);
+ } else {
+ $query_string = join('+',@words);
+ }
+ if ($query_string =~ /^(.*?)\?(.*)$/)
+ {
+ $query_string = $2;
+ $subpath = $1;
+ }
+ return { 'query_string' => $query_string, 'subpath' => $subpath };
+}
+END_OF_FUNC
+
+#####
+# subroutine: read_multipart
+#
+# Read multipart data and store it into our parameters.
+# An interesting feature is that if any of the parts is a file, we
+# create a temporary file and open up a filehandle on it so that the
+# caller can read from it if necessary.
+#####
+'read_multipart' => <<'END_OF_FUNC',
+sub read_multipart {
+ my($self,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
+
+ my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/;
+ $param .= $TAINTED;
+
+ # See RFC 1867, 2183, 2045
+ # NB: File content will be loaded into memory should
+ # content-disposition parsing fail.
+ my ($filename) = $header{'Content-Disposition'}
+ =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
+
+ $filename ||= ''; # quench uninit variable warning
+
+ $filename =~ s/^"([^"]*)"$/$1/;
+ # Test for Opera's multiple upload feature
+ my($multipart) = ( defined( $header{'Content-Type'} ) &&
+ $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
+ 1 : 0;
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ # If no filename specified, then just read the data and assign it
+ # to our parameter list.
+ if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
+ my($value) = $buffer->readBody;
+ $value .= $TAINTED;
+ push(@{$self->{param}{$param}},$value);
+ next;
+ }
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # set the filename to some recognizable value
+ if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
+ $filename = "multipart/mixed";
+ }
+
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = CGITempFile->new($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ # if this is an multipart/mixed attachment, save the header
+ # together with the body for later parsing with an external
+ # MIME parser module
+ if ( $multipart ) {
+ for ( keys %header ) {
+ print $filehandle "$_: $header{$_}${CRLF}";
+ }
+ print $filehandle "${CRLF}";
+ }
+
+ my ($data);
+ local($\) = '';
+ my $totalbytes = 0;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
+ }
+ print $filehandle $data if ($self->{'use_tempfile'});
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
+ hndl => $filehandle,
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{param}{$param}},$filehandle);
+ }
+ }
+}
+END_OF_FUNC
+
+#####
+# subroutine: read_multipart_related
+#
+# Read multipart/related data and store it into our parameters. The
+# first parameter sets the start of the data. The part identified by
+# this Content-ID will not be stored as a file upload, but will be
+# returned by this method. All other parts will be available as file
+# uploads accessible by their Content-ID
+#####
+'read_multipart_related' => <<'END_OF_FUNC',
+sub read_multipart_related {
+ my($self,$start,$boundary,$length) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ my $returnvalue;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+
+ unless (%header) {
+ $self->cgi_error("400 Bad request (malformed multipart POST)");
+ return;
+ }
+
+ my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
+ $param .= $TAINTED;
+
+ # If this is the start part, then just read the data and assign it
+ # to our return variable.
+ if ( $param eq $start ) {
+ $returnvalue = $buffer->readBody;
+ $returnvalue .= $TAINTED;
+ next;
+ }
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ # choose a relatively unpredictable tmpfile sequence number
+ my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
+ for (my $cnt=10;$cnt>0;$cnt--) {
+ next unless $tmpfile = CGITempFile->new($seqno);
+ $tmp = $tmpfile->as_string;
+ last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
+ $seqno += int rand(100);
+ }
+ die "CGI open of tmpfile: $!\n" unless defined $filehandle;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
+ && defined fileno($filehandle);
+
+ my ($data);
+ local($\) = '';
+ my $totalbytes;
+ while (defined($data = $buffer->read)) {
+ if (defined $self->{'.upload_hook'})
+ {
+ $totalbytes += length($data);
+ &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
+ }
+ print $filehandle $data if ($self->{'use_tempfile'});
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+
+ ## Close the filehandle if requested this allows a multipart MIME
+ ## upload to contain many files, and we won't die due to too many
+ ## open file handles. The user can access the files using the hash
+ ## below.
+ close $filehandle if $CLOSE_UPLOAD_FILES;
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ # Use the typeglob as the key, as this is guaranteed to be
+ # unique for each filehandle. Don't use the file descriptor as
+ # this will be re-used for each filehandle if the
+ # close_upload_files feature is used.
+ $self->{'.tmpfiles'}->{$$filehandle}= {
+ hndl => $filehandle,
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{param}{$param}},$filehandle);
+ }
+ }
+ return $returnvalue;
+}
+END_OF_FUNC
+
+
+'upload' =><<'END_OF_FUNC',
+sub upload {
+ my($self,$param_name) = self_or_default(@_);
+ my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
+ return unless @param;
+ return wantarray ? @param : $param[0];
+}
+END_OF_FUNC
+
+'tmpFileName' => <<'END_OF_FUNC',
+sub tmpFileName {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$$filename}->{name} ?
+ $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
+ : '';
+}
+END_OF_FUNC
+
+'uploadInfo' => <<'END_OF_FUNC',
+sub uploadInfo {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$$filename}->{info};
+}
+END_OF_FUNC
+
+# internal routine, don't use
+'_set_values_and_labels' => <<'END_OF_FUNC',
+sub _set_values_and_labels {
+ my $self = shift;
+ my ($v,$l,$n) = @_;
+ $$l = $v if ref($v) eq 'HASH' && !ref($$l);
+ return $self->param($n) if !defined($v);
+ return $v if !ref($v);
+ return ref($v) eq 'HASH' ? keys %$v : @$v;
+}
+END_OF_FUNC
+
+# internal routine, don't use
+'_set_attributes' => <<'END_OF_FUNC',
+sub _set_attributes {
+ my $self = shift;
+ my($element, $attributes) = @_;
+ return '' unless defined($attributes->{$element});
+ $attribs = ' ';
+ for my $attrib (keys %{$attributes->{$element}}) {
+ (my $clean_attrib = $attrib) =~ s/^-//;
+ $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
+ }
+ $attribs =~ s/ $//;
+ return $attribs;
+}
+END_OF_FUNC
+
+'_compile_all' => <<'END_OF_FUNC',
+sub _compile_all {
+ for (@_) {
+ next if defined(&$_);
+ $AUTOLOAD = "CGI::$_";
+ _compile();
+ }
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+;
+
+#########################################################
+# Globals and stubs for other packages that we use.
+#########################################################
+
+################### Fh -- lightweight filehandle ###############
+package Fh;
+
+use overload
+ '""' => \&asString,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+$FH='fh00000';
+
+*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my $self = shift;
+ close $self;
+}
+
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+'asString' => <<'END_OF_FUNC',
+sub asString {
+ my $self = shift;
+ # get rid of package name
+ (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
+ $i =~ s/%(..)/ chr(hex($1)) /eg;
+ return $i.$CGI::TAINTED;
+# BEGIN DEAD CODE
+# This was an extremely clever patch that allowed "use strict refs".
+# Unfortunately it relied on another bug that caused leaky file descriptors.
+# The underlying bug has been fixed, so this no longer works. However
+# "strict refs" still works for some reason.
+# my $self = shift;
+# return ${*{$self}{SCALAR}};
+# END DEAD CODE
+}
+END_OF_FUNC
+
+'compare' => <<'END_OF_FUNC',
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+END_OF_FUNC
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($pack,$name,$file,$delete) = @_;
+ _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
+ require Fcntl unless defined &Fcntl::O_RDWR;
+ (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
+ my $fv = ++$FH . $safename;
+ my $ref = \*{"Fh::$fv"};
+
+ # Note this same regex is also used elsewhere in the same file for CGITempFile::new
+ $file =~ m!^([a-zA-Z0-9_ \'\":/.\$\\\+-]+)$! || return;
+ my $safe = $1;
+ sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
+ unlink($safe) if $delete;
+ CORE::delete $Fh::{$fv};
+ return bless $ref,$pack;
+}
+END_OF_FUNC
+
+'handle' => <<'END_OF_FUNC',
+sub handle {
+ my $self = shift;
+ eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
+ return IO::Handle->new_from_fd(fileno $self,"<");
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+######################## MultipartBuffer ####################
+package MultipartBuffer;
+
+use constant DEBUG => 0;
+
+# how many bytes to read at a time. We use
+# a 4K buffer by default.
+$INITIAL_FILLUNIT = 1024 * 4;
+$TIMEOUT = 240*60; # 4 hour timeout for big files
+$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
+$CRLF=$CGI::CRLF;
+
+#reuse the autoload function
+*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
+
+# avoid autoloader warnings
+sub DESTROY {}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$interface,$boundary,$length) = @_;
+ $FILLUNIT = $INITIAL_FILLUNIT;
+ $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
+
+ # If the user types garbage into the file upload field,
+ # then Netscape passes NOTHING to the server (not good).
+ # We may hang on this read in that case. So we implement
+ # a read timeout. If nothing is ready to read
+ # by then, we return.
+
+ # Netscape seems to be a little bit unreliable
+ # about providing boundary strings.
+ my $boundary_read = 0;
+ if ($boundary) {
+
+ # Under the MIME spec, the boundary consists of the
+ # characters "--" PLUS the Boundary string
+
+ # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
+ # the two extra hyphens. We do a special case here on the user-agent!!!!
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
+
+ } else { # otherwise we find it ourselves
+ my($old);
+ ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
+ $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
+ $length -= length($boundary);
+ chomp($boundary); # remove the CRLF
+ $/ = $old; # restore old line separator
+ $boundary_read++;
+ }
+
+ my $self = {LENGTH=>$length,
+ CHUNKED=>!$length,
+ BOUNDARY=>$boundary,
+ INTERFACE=>$interface,
+ BUFFER=>'',
+ };
+
+ $FILLUNIT = length($boundary)
+ if length($boundary) > $FILLUNIT;
+
+ my $retval = bless $self,ref $package || $package;
+
+ # Read the preamble and the topmost (boundary) line plus the CRLF.
+ unless ($boundary_read) {
+ while ($self->read(0)) { }
+ }
+ die "Malformed multipart POST: data truncated\n" if $self->eof;
+
+ return $retval;
+}
+END_OF_FUNC
+
+'readHeader' => <<'END_OF_FUNC',
+sub readHeader {
+ my($self) = @_;
+ my($end);
+ my($ok) = 0;
+ my($bad) = 0;
+
+ local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
+
+ do {
+ $self->fillBuffer($FILLUNIT);
+ $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
+ $ok++ if $self->{BUFFER} eq '';
+ $bad++ if !$ok && $self->{LENGTH} <= 0;
+ # this was a bad idea
+ # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
+ } until $ok || $bad;
+ return () if $bad;
+
+ #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
+
+ my($header) = substr($self->{BUFFER},0,$end+2);
+ substr($self->{BUFFER},0,$end+4) = '';
+ my %return;
+
+ if ($CGI::EBCDIC) {
+ warn "untranslated header=$header\n" if DEBUG;
+ $header = CGI::Util::ascii2ebcdic($header);
+ warn "translated header=$header\n" if DEBUG;
+ }
+
+ # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
+ # (Folding Long Header Fields), 3.4.3 (Comments)
+ # and 3.4.5 (Quoted-Strings).
+
+ my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
+ $header=~s/$CRLF\s+/ /og; # merge continuation lines
+
+ while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
+ my ($field_name,$field_value) = ($1,$2);
+ $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
+ $return{$field_name}=$field_value;
+ }
+ return %return;
+}
+END_OF_FUNC
+
+# This reads and returns the body as a single scalar value.
+'readBody' => <<'END_OF_FUNC',
+sub readBody {
+ my($self) = @_;
+ my($data);
+ my($returnval)='';
+
+ #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
+
+ while (defined($data = $self->read)) {
+ $returnval .= $data;
+ }
+
+ if ($CGI::EBCDIC) {
+ warn "untranslated body=$returnval\n" if DEBUG;
+ $returnval = CGI::Util::ascii2ebcdic($returnval);
+ warn "translated body=$returnval\n" if DEBUG;
+ }
+ return $returnval;
+}
+END_OF_FUNC
+
+# This will read $bytes or until the boundary is hit, whichever happens
+# first. After the boundary is hit, we return undef. The next read will
+# skip over the boundary and begin reading again;
+'read' => <<'END_OF_FUNC',
+sub read {
+ my($self,$bytes) = @_;
+
+ # default number of bytes to read
+ $bytes = $bytes || $FILLUNIT;
+
+ # Fill up our internal buffer in such a way that the boundary
+ # is never split between reads.
+ $self->fillBuffer($bytes);
+
+ my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
+ my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
+
+ # Find the boundary in the buffer (it may not be there).
+ my $start = index($self->{BUFFER},$boundary_start);
+
+ warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
+
+ # protect against malformed multipart POST operations
+ die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
+
+ #EBCDIC NOTE: want to translate boundary search into ASCII here.
+
+ # If the boundary begins the data, then skip past it
+ # and return undef.
+ if ($start == 0) {
+
+ # clear us out completely if we've hit the last boundary.
+ if (index($self->{BUFFER},$boundary_end)==0) {
+ $self->{BUFFER}='';
+ $self->{LENGTH}=0;
+ return undef;
+ }
+
+ # just remove the boundary.
+ substr($self->{BUFFER},0,length($boundary_start))='';
+ $self->{BUFFER} =~ s/^\012\015?//;
+ return undef;
+ }
+
+ my $bytesToReturn;
+ if ($start > 0) { # read up to the boundary
+ $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
+ } else { # read the requested number of bytes
+ # leave enough bytes in the buffer to allow us to read
+ # the boundary. Thanks to Kevin Hendrick for finding
+ # this one.
+ $bytesToReturn = $bytes - (length($boundary_start)+1);
+ }
+
+ my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
+ substr($self->{BUFFER},0,$bytesToReturn)='';
+
+ # If we hit the boundary, remove the CRLF from the end.
+ return ($bytesToReturn==$start)
+ ? substr($returnval,0,-2) : $returnval;
+}
+END_OF_FUNC
+
+
+# This fills up our internal buffer in such a way that the
+# boundary is never split between reads
+'fillBuffer' => <<'END_OF_FUNC',
+sub fillBuffer {
+ my($self,$bytes) = @_;
+ return unless $self->{CHUNKED} || $self->{LENGTH};
+
+ my($boundaryLength) = length($self->{BOUNDARY});
+ my($bufferLength) = length($self->{BUFFER});
+ my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
+ $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
+
+ # Try to read some data. We may hang here if the browser is screwed up.
+ my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
+ $bytesToRead,
+ $bufferLength);
+ warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
+ $self->{BUFFER} = '' unless defined $self->{BUFFER};
+
+ # An apparent bug in the Apache server causes the read()
+ # to return zero bytes repeatedly without blocking if the
+ # remote user aborts during a file transfer. I don't know how
+ # they manage this, but the workaround is to abort if we get
+ # more than SPIN_LOOP_MAX consecutive zero reads.
+ if ($bytesRead <= 0) {
+ die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
+ if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
+ } else {
+ $self->{ZERO_LOOP_COUNTER}=0;
+ }
+
+ $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
+}
+END_OF_FUNC
+
+
+# Return true when we've finished reading
+'eof' => <<'END_OF_FUNC'
+sub eof {
+ my($self) = @_;
+ return 1 if (length($self->{BUFFER}) == 0)
+ && ($self->{LENGTH} <= 0);
+ undef;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+####################################################################################
+################################## TEMPORARY FILES #################################
+####################################################################################
+package CGITempFile;
+
+sub find_tempdir {
+ $SL = $CGI::SL;
+ $MAC = $CGI::OS eq 'MACINTOSH';
+ my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
+ unless (defined $TMPDIRECTORY) {
+ @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
+ "C:${SL}temp","${SL}tmp","${SL}temp",
+ "${vol}${SL}Temporary Items",
+ "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
+ "C:${SL}system${SL}temp");
+
+ if( $CGI::OS eq 'WINDOWS' ){
+ # PeterH: These evars may not exist if this is invoked within a service and untainting
+ # is in effect - with 'use warnings' the undefined array entries causes Perl to die
+ unshift(@TEMP,$ENV{TEMP}) if defined $ENV{TEMP};
+ unshift(@TEMP,$ENV{TMP}) if defined $ENV{TMP};
+ unshift(@TEMP,$ENV{WINDIR} . $SL . 'TEMP') if defined $ENV{WINDIR};
+ }
+
+ unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
+
+ # this feature was supposed to provide per-user tmpfiles, but
+ # it is problematic.
+ # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
+ # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
+ # : can generate a 'getpwuid() not implemented' exception, even though
+ # : it's never called. Found under DOS/Win with the DJGPP perl port.
+ # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
+ # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
+
+ for (@TEMP) {
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ }
+ }
+ $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+}
+
+find_tempdir();
+
+$MAXTRIES = 5000;
+
+# cute feature, but overload implementation broke it
+# %OVERLOAD = ('""'=>'as_string');
+*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+sub DESTROY {
+ my($self) = @_;
+ $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
+ my $safe = $1; # untaint operation
+ unlink $safe; # get rid of the file
+}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$sequence) = @_;
+ my $filename;
+ find_tempdir() unless -w $TMPDIRECTORY;
+ for (my $i = 0; $i < $MAXTRIES; $i++) {
+ last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
+ }
+ # check that it is a more-or-less valid filename
+ # Note this same regex is also used elsewhere in the same file for Fh::new
+ return unless $filename =~ m!^([a-zA-Z0-9_ \'\":/.\$\\\+-]+)$!;
+ # this used to untaint, now it doesn't
+ # $filename = $1;
+ return bless \$filename;
+}
+END_OF_FUNC
+
+'as_string' => <<'END_OF_FUNC'
+sub as_string {
+ my($self) = @_;
+ return $$self;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+package CGI;
+
+# We get a whole bunch of warnings about "possibly uninitialized variables"
+# when running with the -w switch. Touch them all once to get rid of the
+# warnings. This is ugly and I hate it.
+if ($^W) {
+ $CGI::CGI = '';
+ $CGI::CGI=<<EOF;
+ $CGI::VERSION;
+ $MultipartBuffer::SPIN_LOOP_MAX;
+ $MultipartBuffer::CRLF;
+ $MultipartBuffer::TIMEOUT;
+ $MultipartBuffer::INITIAL_FILLUNIT;
+EOF
+ ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI - Handle Common Gateway Interface requests and responses
+
+=head1 SYNOPSIS
+
+ use CGI;
+
+ my $q = CGI->new;
+
+ # Process an HTTP request
+ @values = $q->param('form_field');
+
+ $fh = $q->upload('file_field');
+
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
+
+ # Prepare various HTTP responses
+ print $q->header();
+ print $q->header('application/json');
+
+ $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
+ $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
+ print $q->header(
+ -type => 'image/gif',
+ -expires => '+3d',
+ -cookie => [$cookie1,$cookie2]
+ );
+
+ print $q->redirect('http://somewhere.else/in/movie/land');
+
+=head1 DESCRIPTION
+
+CGI.pm is a stable, complete and mature solution for processing and preparing
+HTTP requests and responses. Major features including processing form
+submissions, file uploads, reading and writing cookies, query string generation
+and manipulation, and processing and preparing HTTP headers. Some HTML
+generation utilities are included as well.
+
+CGI.pm performs very well in in a vanilla CGI.pm environment and also comes
+with built-in support for mod_perl and mod_perl2 as well as FastCGI.
+
+It has the benefit of having developed and refined over 10 years with input
+from dozens of contributors and being deployed on thousands of websites.
+CGI.pm has been included in the Perl distribution since Perl 5.4, and has
+become a de-facto standard.
+
+=head2 PROGRAMMING STYLE
+
+There are two styles of programming with CGI.pm, an object-oriented
+style and a function-oriented style. In the object-oriented style you
+create one or more CGI objects and then use object methods to create
+the various elements of the page. Each CGI object starts out with the
+list of named parameters that were passed to your CGI script by the
+server. You can modify the objects, save them to a file or database
+and recreate them. Because each object corresponds to the "state" of
+the CGI script, and because each object's parameter list is
+independent of the others, this allows you to save the state of the
+script and restore it later.
+
+For example, using the object oriented style, here is how you create
+a simple "Hello World" HTML page:
+
+ #!/usr/local/bin/perl -w
+ use CGI; # load CGI routines
+ $q = CGI->new; # create new CGI object
+ print $q->header, # create the HTTP header
+ $q->start_html('hello world'), # start the HTML
+ $q->h1('hello world'), # level 1 header
+ $q->end_html; # end the HTML
+
+In the function-oriented style, there is one default CGI object that
+you rarely deal with directly. Instead you just call functions to
+retrieve CGI parameters, create HTML tags, manage cookies, and so
+on. This provides you with a cleaner programming interface, but
+limits you to using one CGI object at a time. The following example
+prints the same page, but uses the function-oriented interface.
+The main differences are that we now need to import a set of functions
+into our name space (usually the "standard" functions), and we don't
+need to create the CGI object.
+
+ #!/usr/local/bin/perl
+ use CGI qw/:standard/; # load standard CGI routines
+ print header, # create the HTTP header
+ start_html('hello world'), # start the HTML
+ h1('hello world'), # level 1 header
+ end_html; # end the HTML
+
+The examples in this document mainly use the object-oriented style.
+See HOW TO IMPORT FUNCTIONS for important information on
+function-oriented programming in CGI.pm
+
+=head2 CALLING CGI.PM ROUTINES
+
+Most CGI.pm routines accept several arguments, sometimes as many as 20
+optional ones! To simplify this interface, all routines use a named
+argument calling style that looks like this:
+
+ print $q->header(-type=>'image/gif',-expires=>'+3d');
+
+Each argument name is preceded by a dash. Neither case nor order
+matters in the argument list. -type, -Type, and -TYPE are all
+acceptable. In fact, only the first argument needs to begin with a
+dash. If a dash is present in the first argument, CGI.pm assumes
+dashes for the subsequent ones.
+
+Several routines are commonly called with just one argument. In the
+case of these routines you can provide the single argument without an
+argument name. header() happens to be one of these routines. In this
+case, the single argument is the document type.
+
+ print $q->header('text/html');
+
+Other such routines are documented below.
+
+Sometimes named arguments expect a scalar, sometimes a reference to an
+array, and sometimes a reference to a hash. Often, you can pass any
+type of argument and the routine will do whatever is most appropriate.
+For example, the param() routine is used to set a CGI parameter to a
+single or a multi-valued value. The two cases are shown below:
+
+ $q->param(-name=>'veggie',-value=>'tomato');
+ $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
+
+A large number of routines in CGI.pm actually aren't specifically
+defined in the module, but are generated automatically as needed.
+These are the "HTML shortcuts," routines that generate HTML tags for
+use in dynamically-generated pages. HTML tags have both attributes
+(the attribute="value" pairs within the tag itself) and contents (the
+part between the opening and closing pairs.) To distinguish between
+attributes and contents, CGI.pm uses the convention of passing HTML
+attributes as a hash reference as the first argument, and the
+contents, if any, as any subsequent arguments. It works out like
+this:
+
+ Code Generated HTML
+ ---- --------------
+ h1() <h1>
+ h1('some','contents'); <h1>some contents</h1>
+ h1({-align=>left}); <h1 align="LEFT">
+ h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
+
+HTML tags are described in more detail later.
+
+Many newcomers to CGI.pm are puzzled by the difference between the
+calling conventions for the HTML shortcuts, which require curly braces
+around the HTML tag attributes, and the calling conventions for other
+routines, which manage to generate attributes without the curly
+brackets. Don't be confused. As a convenience the curly braces are
+optional in all but the HTML shortcuts. If you like, you can use
+curly braces when calling any routine that takes named arguments. For
+example:
+
+ print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
+
+If you use the B<-w> switch, you will be warned that some CGI.pm argument
+names conflict with built-in Perl functions. The most frequent of
+these is the -values argument, used to create multi-valued menus,
+radio button clusters and the like. To get around this warning, you
+have several choices:
+
+=over 4
+
+=item 1.
+
+Use another name for the argument, if one is available.
+For example, -value is an alias for -values.
+
+=item 2.
+
+Change the capitalization, e.g. -Values
+
+=item 3.
+
+Put quotes around the argument name, e.g. '-values'
+
+=back
+
+Many routines will do something useful with a named argument that it
+doesn't recognize. For example, you can produce non-standard HTTP
+header fields by providing them as named arguments:
+
+ print $q->header(-type => 'text/html',
+ -cost => 'Three smackers',
+ -annoyance_level => 'high',
+ -complaints_to => 'bit bucket');
+
+This will produce the following nonstandard HTTP header:
+
+ HTTP/1.0 200 OK
+ Cost: Three smackers
+ Annoyance-level: high
+ Complaints-to: bit bucket
+ Content-type: text/html
+
+Notice the way that underscores are translated automatically into
+hyphens. HTML-generating routines perform a different type of
+translation.
+
+This feature allows you to keep up with the rapidly changing HTTP and
+HTML "standards".
+
+=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
+
+ $query = CGI->new;
+
+This will parse the input (from both POST and GET methods) and store
+it into a perl5 object called $query.
+
+Any filehandles from file uploads will have their position reset to
+the beginning of the file.
+
+=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
+
+ $query = CGI->new(INPUTFILE);
+
+If you provide a file handle to the new() method, it will read
+parameters from the file (or STDIN, or whatever). The file can be in
+any of the forms describing below under debugging (i.e. a series of
+newline delimited TAG=VALUE pairs will work). Conveniently, this type
+of file is created by the save() method (see below). Multiple records
+can be saved and restored.
+
+Perl purists will be pleased to know that this syntax accepts
+references to file handles, or even references to filehandle globs,
+which is the "official" way to pass a filehandle:
+
+ $query = CGI->new(\*STDIN);
+
+You can also initialize the CGI object with a FileHandle or IO::File
+object.
+
+If you are using the function-oriented interface and want to
+initialize CGI state from a file handle, the way to do this is with
+B<restore_parameters()>. This will (re)initialize the
+default CGI object from the indicated file handle.
+
+ open (IN,"test.in") || die;
+ restore_parameters(IN);
+ close IN;
+
+You can also initialize the query object from a hash
+reference:
+
+ $query = CGI->new( {'dinosaur'=>'barney',
+ 'song'=>'I love you',
+ 'friends'=>[qw/Jessica George Nancy/]}
+ );
+
+or from a properly formatted, URL-escaped query string:
+
+ $query = CGI->new('dinosaur=barney&color=purple');
+
+or from a previously existing CGI object (currently this clones the
+parameter list, but none of the other object-specific fields, such as
+autoescaping):
+
+ $old_query = CGI->new;
+ $new_query = CGI->new($old_query);
+
+To create an empty query, initialize it from an empty string or hash:
+
+ $empty_query = CGI->new("");
+
+ -or-
+
+ $empty_query = CGI->new({});
+
+=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
+
+ @keywords = $query->keywords
+
+If the script was invoked as the result of an <ISINDEX> search, the
+parsed keywords can be obtained as an array using the keywords() method.
+
+=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
+
+ @names = $query->param
+
+If the script was invoked with a parameter list
+(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
+will return the parameter names as a list. If the script was invoked
+as an <ISINDEX> script and contains a string without ampersands
+(e.g. "value1+value2+value3") , there will be a single parameter named
+"keywords" containing the "+"-delimited keywords.
+
+NOTE: As of version 1.5, the array of parameter names returned will
+be in the same order as they were submitted by the browser.
+Usually this order is the same as the order in which the
+parameters are defined in the form (however, this isn't part
+of the spec, and so isn't guaranteed).
+
+=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
+
+ @values = $query->param('foo');
+
+ -or-
+
+ $value = $query->param('foo');
+
+Pass the param() method a single argument to fetch the value of the
+named parameter. If the parameter is multivalued (e.g. from multiple
+selections in a scrolling list), you can ask to receive an array. Otherwise
+the method will return a single value.
+
+If a value is not given in the query string, as in the queries
+"name1=&name2=", it will be returned as an empty string.
+
+
+If the parameter does not exist at all, then param() will return undef
+in a scalar context, and the empty list in a list context.
+
+
+=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
+
+ $query->param('foo','an','array','of','values');
+
+This sets the value for the named parameter 'foo' to an array of
+values. This is one way to change the value of a field AFTER
+the script has been invoked once before. (Another way is with
+the -override parameter accepted by all methods that generate
+form elements.)
+
+param() also recognizes a named parameter style of calling described
+in more detail later:
+
+ $query->param(-name=>'foo',-values=>['an','array','of','values']);
+
+ -or-
+
+ $query->param(-name=>'foo',-value=>'the value');
+
+=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
+
+ $query->append(-name=>'foo',-values=>['yet','more','values']);
+
+This adds a value or list of values to the named parameter. The
+values are appended to the end of the parameter if it already exists.
+Otherwise the parameter is created. Note that this method only
+recognizes the named argument calling syntax.
+
+=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
+
+ $query->import_names('R');
+
+This creates a series of variables in the 'R' namespace. For example,
+$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
+If no namespace is given, this method will assume 'Q'.
+WARNING: don't import anything into 'main'; this is a major security
+risk!!!!
+
+NOTE 1: Variable names are transformed as necessary into legal Perl
+variable names. All non-legal characters are transformed into
+underscores. If you need to keep the original names, you should use
+the param() method instead to access CGI variables by name.
+
+NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
+this name has been removed completely to avoid conflict with the built-in
+Perl module B<import> operator.
+
+=head2 DELETING A PARAMETER COMPLETELY:
+
+ $query->delete('foo','bar','baz');
+
+This completely clears a list of parameters. It sometimes useful for
+resetting parameters that you don't want passed down between script
+invocations.
+
+If you are using the function call interface, use "Delete()" instead
+to avoid conflicts with Perl's built-in delete operator.
+
+=head2 DELETING ALL PARAMETERS:
+
+ $query->delete_all();
+
+This clears the CGI object completely. It might be useful to ensure
+that all the defaults are taken when you create a fill-out form.
+
+Use Delete_all() instead if you are using the function call interface.
+
+=head2 HANDLING NON-URLENCODED ARGUMENTS
+
+
+If POSTed data is not of type application/x-www-form-urlencoded or
+multipart/form-data, then the POSTed data will not be processed, but
+instead be returned as-is in a parameter named POSTDATA. To retrieve
+it, use code like this:
+
+ my $data = $query->param('POSTDATA');
+
+Likewise if PUTed data can be retrieved with code like this:
+
+ my $data = $query->param('PUTDATA');
+
+(If you don't know what the preceding means, don't worry about it. It
+only affects people trying to use CGI for XML processing and other
+specialized tasks.)
+
+
+=head2 DIRECT ACCESS TO THE PARAMETER LIST:
+
+ $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
+ unshift @{$q->param_fetch(-name=>'address')},'George Munster';
+
+If you need access to the parameter list in a way that isn't covered
+by the methods above, you can obtain a direct reference to it by
+calling the B<param_fetch()> method with the name of the . This
+will return an array reference to the named parameters, which you then
+can manipulate in any way you like.
+
+You can also use a named argument style using the B<-name> argument.
+
+=head2 FETCHING THE PARAMETER LIST AS A HASH:
+
+ $params = $q->Vars;
+ print $params->{'address'};
+ @foo = split("\0",$params->{'foo'});
+ %params = $q->Vars;
+
+ use CGI ':cgi-lib';
+ $params = Vars;
+
+Many people want to fetch the entire parameter list as a hash in which
+the keys are the names of the CGI parameters, and the values are the
+parameters' values. The Vars() method does this. Called in a scalar
+context, it returns the parameter list as a tied hash reference.
+Changing a key changes the value of the parameter in the underlying
+CGI parameter list. Called in a list context, it returns the
+parameter list as an ordinary hash. This allows you to read the
+contents of the parameter list, but not to change it.
+
+When using this, the thing you must watch out for are multivalued CGI
+parameters. Because a hash cannot distinguish between scalar and
+list context, multivalued parameters will be returned as a packed
+string, separated by the "\0" (null) character. You must split this
+packed string in order to get at the individual values. This is the
+convention introduced long ago by Steve Brenner in his cgi-lib.pl
+module for Perl version 4.
+
+If you wish to use Vars() as a function, import the I<:cgi-lib> set of
+function calls (also see the section on CGI-LIB compatibility).
+
+=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
+
+ $query->save(\*FILEHANDLE)
+
+This will write the current state of the form to the provided
+filehandle. You can read it back in by providing a filehandle
+to the new() method. Note that the filehandle can be a file, a pipe,
+or whatever!
+
+The format of the saved file is:
+
+ NAME1=VALUE1
+ NAME1=VALUE1'
+ NAME2=VALUE2
+ NAME3=VALUE3
+ =
+
+Both name and value are URL escaped. Multi-valued CGI parameters are
+represented as repeated names. A session record is delimited by a
+single = symbol. You can write out multiple records and read them
+back in with several calls to B<new>. You can do this across several
+sessions by opening the file in append mode, allowing you to create
+primitive guest books, or to keep a history of users' queries. Here's
+a short example of creating multiple session records:
+
+ use CGI;
+
+ open (OUT,'>>','test.out') || die;
+ $records = 5;
+ for (0..$records) {
+ my $q = CGI->new;
+ $q->param(-name=>'counter',-value=>$_);
+ $q->save(\*OUT);
+ }
+ close OUT;
+
+ # reopen for reading
+ open (IN,'<','test.out') || die;
+ while (!eof(IN)) {
+ my $q = CGI->new(\*IN);
+ print $q->param('counter'),"\n";
+ }
+
+The file format used for save/restore is identical to that used by the
+Whitehead Genome Center's data exchange format "Boulderio", and can be
+manipulated and even databased using Boulderio utilities. See
+
+ http://stein.cshl.org/boulder/
+
+for further details.
+
+If you wish to use this method from the function-oriented (non-OO)
+interface, the exported name for this method is B<save_parameters()>.
+
+=head2 RETRIEVING CGI ERRORS
+
+Errors can occur while processing user input, particularly when
+processing uploaded files. When these errors occur, CGI will stop
+processing and return an empty parameter list. You can test for
+the existence and nature of errors using the I<cgi_error()> function.
+The error messages are formatted as HTTP status codes. You can either
+incorporate the error text into an HTML page, or use it as the value
+of the HTTP status:
+
+ my $error = $q->cgi_error;
+ if ($error) {
+ print $q->header(-status=>$error),
+ $q->start_html('Problems'),
+ $q->h2('Request not processed'),
+ $q->strong($error);
+ exit 0;
+ }
+
+When using the function-oriented interface (see the next section),
+errors may only occur the first time you call I<param()>. Be ready
+for this!
+
+=head2 USING THE FUNCTION-ORIENTED INTERFACE
+
+To use the function-oriented interface, you must specify which CGI.pm
+routines or sets of routines to import into your script's namespace.
+There is a small overhead associated with this importation, but it
+isn't much.
+
+ use CGI <list of methods>;
+
+The listed methods will be imported into the current package; you can
+call them directly without creating a CGI object first. This example
+shows how to import the B<param()> and B<header()>
+methods, and then use them directly:
+
+ use CGI 'param','header';
+ print header('text/plain');
+ $zipcode = param('zipcode');
+
+More frequently, you'll import common sets of functions by referring
+to the groups by name. All function sets are preceded with a ":"
+character as in ":html3" (for tags defined in the HTML 3 standard).
+
+Here is a list of the function sets you can import:
+
+=over 4
+
+=item B<:cgi>
+
+Import all CGI-handling methods, such as B<param()>, B<path_info()>
+and the like.
+
+=item B<:form>
+
+Import all fill-out form generating methods, such as B<textfield()>.
+
+=item B<:html2>
+
+Import all methods that generate HTML 2.0 standard elements.
+
+=item B<:html3>
+
+Import all methods that generate HTML 3.0 elements (such as
+<table>, <super> and <sub>).
+
+=item B<:html4>
+
+Import all methods that generate HTML 4 elements (such as
+<abbrev>, <acronym> and <thead>).
+
+=item B<:netscape>
+
+Import the <blink>, <fontsize> and <center> tags.
+
+=item B<:html>
+
+Import all HTML-generating shortcuts (i.e. 'html2', 'html3', 'html4' and 'netscape')
+
+=item B<:standard>
+
+Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
+
+=item B<:all>
+
+Import all the available methods. For the full list, see the CGI.pm
+code, where the variable %EXPORT_TAGS is defined.
+
+=back
+
+If you import a function name that is not part of CGI.pm, the module
+will treat it as a new HTML tag and generate the appropriate
+subroutine. You can then use it like any other HTML tag. This is to
+provide for the rapidly-evolving HTML "standard." For example, say
+Microsoft comes out with a new tag called <gradient> (which causes the
+user's desktop to be flooded with a rotating gradient fill until his
+machine reboots). You don't need to wait for a new version of CGI.pm
+to start using it immediately:
+
+ use CGI qw/:standard :html3 gradient/;
+ print gradient({-start=>'red',-end=>'blue'});
+
+Note that in the interests of execution speed CGI.pm does B<not> use
+the standard L<Exporter> syntax for specifying load symbols. This may
+change in the future.
+
+If you import any of the state-maintaining CGI or form-generating
+methods, a default CGI object will be created and initialized
+automatically the first time you use any of the methods that require
+one to be present. This includes B<param()>, B<textfield()>,
+B<submit()> and the like. (If you need direct access to the CGI
+object, you can find it in the global variable B<$CGI::Q>). By
+importing CGI.pm methods, you can create visually elegant scripts:
+
+ use CGI qw/:standard/;
+ print
+ header,
+ start_html('Simple Script'),
+ h1('Simple Script'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?",
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','moe']),p,
+ "What's your favorite color?",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr,"\n";
+
+ if (param) {
+ print
+ "Your name is ",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),".\n";
+ }
+ print end_html;
+
+=head2 PRAGMAS
+
+In addition to the function sets, there are a number of pragmas that
+you can import. Pragmas, which are always preceded by a hyphen,
+change the way that CGI.pm functions in various ways. Pragmas,
+function sets, and individual functions can all be imported in the
+same use() line. For example, the following use statement imports the
+standard set of functions and enables debugging mode (pragma
+-debug):
+
+ use CGI qw/:standard -debug/;
+
+The current list of pragmas is as follows:
+
+=over 4
+
+=item -any
+
+When you I<use CGI -any>, then any method that the query object
+doesn't recognize will be interpreted as a new HTML tag. This allows
+you to support the next I<ad hoc> HTML
+extension. This lets you go wild with new and unsupported tags:
+
+ use CGI qw(-any);
+ $q=CGI->new;
+ print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
+
+Since using <cite>any</cite> causes any mistyped method name
+to be interpreted as an HTML tag, use it with care or not at
+all.
+
+=item -compile
+
+This causes the indicated autoloaded methods to be compiled up front,
+rather than deferred to later. This is useful for scripts that run
+for an extended period of time under FastCGI or mod_perl, and for
+those destined to be crunched by Malcolm Beattie's Perl compiler. Use
+it in conjunction with the methods or method families you plan to use.
+
+ use CGI qw(-compile :standard :html3);
+
+or even
+
+ use CGI qw(-compile :all);
+
+Note that using the -compile pragma in this way will always have
+the effect of importing the compiled functions into the current
+namespace. If you want to compile without importing use the
+compile() method instead:
+
+ use CGI();
+ CGI->compile();
+
+This is particularly useful in a mod_perl environment, in which you
+might want to precompile all CGI routines in a startup script, and
+then import the functions individually in each mod_perl script.
+
+=item -nosticky
+
+By default the CGI module implements a state-preserving behavior
+called "sticky" fields. The way this works is that if you are
+regenerating a form, the methods that generate the form field values
+will interrogate param() to see if similarly-named parameters are
+present in the query string. If they find a like-named parameter, they
+will use it to set their default values.
+
+Sometimes this isn't what you want. The B<-nosticky> pragma prevents
+this behavior. You can also selectively change the sticky behavior in
+each element that you generate.
+
+=item -tabindex
+
+Automatically add tab index attributes to each form field. With this
+option turned off, you can still add tab indexes manually by passing a
+-tabindex option to each field-generating method.
+
+=item -no_undef_params
+
+This keeps CGI.pm from including undef params in the parameter list.
+
+=item -no_xhtml
+
+By default, CGI.pm versions 2.69 and higher emit XHTML
+(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
+feature. Thanks to Michalis Kabrianis <kabrianis@hellug.gr> for this
+feature.
+
+If start_html()'s -dtd parameter specifies an HTML 2.0,
+3.2, 4.0 or 4.01 DTD,
+XHTML will automatically be disabled without needing to use this
+pragma.
+
+=item -utf8
+
+This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
+care, as it will interfere with the processing of binary uploads. It
+is better to manually select which fields are expected to return utf-8
+strings and convert them using code like this:
+
+ use Encode;
+ my $arg = decode utf8=>param('foo');
+
+=item -nph
+
+This makes CGI.pm produce a header appropriate for an NPH (no
+parsed header) script. You may need to do other things as well
+to tell the server that the script is NPH. See the discussion
+of NPH scripts below.
+
+=item -newstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+semicolons rather than ampersands. For example:
+
+ ?name=fred;age=24;favorite_color=3
+
+Semicolon-delimited query strings are always accepted, and will be emitted by
+self_url() and query_string(). newstyle_urls became the default in version
+2.64.
+
+=item -oldstyle_urls
+
+Separate the name=value pairs in CGI parameter query strings with
+ampersands rather than semicolons. This is no longer the default.
+
+=item -autoload
+
+This overrides the autoloader so that any function in your program
+that is not recognized is referred to CGI.pm for possible evaluation.
+This allows you to use all the CGI.pm functions without adding them to
+your symbol table, which is of concern for mod_perl users who are
+worried about memory consumption. I<Warning:> when
+I<-autoload> is in effect, you cannot use "poetry mode"
+(functions without the parenthesis). Use I<hr()> rather
+than I<hr>, or add something like I<use subs qw/hr p header/>
+to the top of your script.
+
+=item -no_debug
+
+This turns off the command-line processing features. If you want to
+run a CGI.pm script from the command line to produce HTML, and you
+don't want it to read CGI parameters from the command line or STDIN,
+then use this pragma:
+
+ use CGI qw(-no_debug :standard);
+
+=item -debug
+
+This turns on full debugging. In addition to reading CGI arguments
+from the command-line processing, CGI.pm will pause and try to read
+arguments from STDIN, producing the message "(offline mode: enter
+name=value pairs on standard input)" features.
+
+See the section on debugging for more details.
+
+=item -private_tempfiles
+
+CGI.pm can process uploaded file. Ordinarily it spools the uploaded
+file to a temporary directory, then deletes the file when done.
+However, this opens the risk of eavesdropping as described in the file
+upload section. Another CGI script author could peek at this data
+during the upload, even if it is confidential information. On Unix
+systems, the -private_tempfiles pragma will cause the temporary file
+to be unlinked as soon as it is opened and before any data is written
+into it, reducing, but not eliminating the risk of eavesdropping
+(there is still a potential race condition). To make life harder for
+the attacker, the program chooses tempfile names by calculating a 32
+bit checksum of the incoming HTTP headers.
+
+To ensure that the temporary file cannot be read by other CGI scripts,
+use suEXEC or a CGI wrapper program to run your script. The temporary
+file is created with mode 0600 (neither world nor group readable).
+
+The temporary directory is selected using the following algorithm:
+
+ 1. if the current user (e.g. "nobody") has a directory named
+ "tmp" in its home directory, use that (Unix systems only).
+
+ 2. if the environment variable TMPDIR exists, use the location
+ indicated.
+
+ 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
+ /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
+
+Each of these locations is checked that it is a directory and is
+writable. If not, the algorithm tries the next choice.
+
+=back
+
+=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
+
+Many of the methods generate HTML tags. As described below, tag
+functions automatically generate both the opening and closing tags.
+For example:
+
+ print h1('Level 1 Header');
+
+produces
+
+ <h1>Level 1 Header</h1>
+
+There will be some times when you want to produce the start and end
+tags yourself. In this case, you can use the form start_I<tag_name>
+and end_I<tag_name>, as in:
+
+ print start_h1,'Level 1 Header',end_h1;
+
+With a few exceptions (described below), start_I<tag_name> and
+end_I<tag_name> functions are not generated automatically when you
+I<use CGI>. However, you can specify the tags you want to generate
+I<start/end> functions for by putting an asterisk in front of their
+name, or, alternatively, requesting either "start_I<tag_name>" or
+"end_I<tag_name>" in the import list.
+
+Example:
+
+ use CGI qw/:standard *table start_ul/;
+
+In this example, the following functions are generated in addition to
+the standard ones:
+
+=over 4
+
+=item 1. start_table() (generates a <table> tag)
+
+=item 2. end_table() (generates a </table> tag)
+
+=item 3. start_ul() (generates a <ul> tag)
+
+=item 4. end_ul() (generates a </ul> tag)
+
+=back
+
+=head1 GENERATING DYNAMIC DOCUMENTS
+
+Most of CGI.pm's functions deal with creating documents on the fly.
+Generally you will produce the HTTP header first, followed by the
+document itself. CGI.pm provides functions for generating HTTP
+headers of various types as well as for generating HTML. For creating
+GIF images, see the GD.pm module.
+
+Each of these functions produces a fragment of HTML or HTTP which you
+can print out directly so that it displays in the browser window,
+append to a string, or save to a file for later use.
+
+=head2 CREATING A STANDARD HTTP HEADER:
+
+Normally the first thing you will do in any CGI script is print out an
+HTTP header. This tells the browser what type of document to expect,
+and gives other optional information, such as the language, expiration
+date, and whether to cache the document. The header can also be
+manipulated for special purposes, such as server push and pay per view
+pages.
+
+ print header;
+
+ -or-
+
+ print header('image/gif');
+
+ -or-
+
+ print header('text/html','204 No response');
+
+ -or-
+
+ print header(-type=>'image/gif',
+ -nph=>1,
+ -status=>'402 Payment required',
+ -expires=>'+3d',
+ -cookie=>$cookie,
+ -charset=>'utf-7',
+ -attachment=>'foo.gif',
+ -Cost=>'$2.00');
+
+header() returns the Content-type: header. You can provide your own
+MIME type if you choose, otherwise it defaults to text/html. An
+optional second parameter specifies the status code and a human-readable
+message. For example, you can specify 204, "No response" to create a
+script that tells the browser to do nothing at all.
+
+The last example shows the named argument style for passing arguments
+to the CGI methods using named parameters. Recognized parameters are
+B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
+parameters will be stripped of their initial hyphens and turned into
+header fields, allowing you to specify any HTTP header you desire.
+Internal underscores will be turned into hyphens:
+
+ print header(-Content_length=>3002);
+
+Most browsers will not cache the output from CGI scripts. Every time
+the browser reloads the page, the script is invoked anew. You can
+change this behavior with the B<-expires> parameter. When you specify
+an absolute or relative expiration interval with this parameter, some
+browsers and proxy servers will cache the script's output until the
+indicated expiration date. The following forms are all valid for the
+-expires field:
+
+ +30s 30 seconds from now
+ +10m ten minutes from now
+ +1h one hour from now
+ -1d yesterday (i.e. "ASAP!")
+ now immediately
+ +3M in three months
+ +10y in ten years time
+ Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
+
+The B<-cookie> parameter generates a header that tells the browser to provide
+a "magic cookie" during all subsequent transactions with your script.
+Some cookies have a special format that includes interesting attributes
+such as expiration time. Use the cookie() method to create and retrieve
+session cookies.
+
+The B<-nph> parameter, if set to a true value, will issue the correct
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers that expect all their scripts to be NPH.
+
+The B<-charset> parameter can be used to control the character set
+sent to the browser. If not provided, defaults to ISO-8859-1. As a
+side effect, this sets the charset() method as well.
+
+The B<-attachment> parameter can be used to turn the page into an
+attachment. Instead of displaying the page, some browsers will prompt
+the user to save it to disk. The value of the argument is the
+suggested name for the saved file. In order for this to work, you may
+have to set the B<-type> to "application/octet-stream".
+
+The B<-p3p> parameter will add a P3P tag to the outgoing header. The
+parameter can be an arrayref or a space-delimited string of P3P tags.
+For example:
+
+ print header(-p3p=>[qw(CAO DSP LAW CURa)]);
+ print header(-p3p=>'CAO DSP LAW CURa');
+
+In either case, the outgoing header will be formatted as:
+
+ P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
+
+Note that if a header value contains a carriage return, a leading space will be
+added to each new line that doesn't already have one as specified by RFC2616
+section 4.2. For example:
+
+ print header( -ingredients => "ham\neggs\nbacon" );
+
+will generate
+
+ Ingredients: ham
+ eggs
+ bacon
+
+=head2 GENERATING A REDIRECTION HEADER
+
+ print $q->redirect('http://somewhere.else/in/movie/land');
+
+Sometimes you don't want to produce a document yourself, but simply
+redirect the browser elsewhere, perhaps choosing a URL based on the
+time of day or the identity of the user.
+
+The redirect() method redirects the browser to a different URL. If
+you use redirection like this, you should B<not> print out a header as
+well.
+
+You should always use full URLs (including the http: or ftp: part) in
+redirection requests. Relative URLs will not work correctly.
+
+You can also use named arguments:
+
+ print $q->redirect(
+ -uri=>'http://somewhere.else/in/movie/land',
+ -nph=>1,
+ -status=>301);
+
+All names arguments recognized by header() are also recognized by
+redirect(). However, most HTTP headers, including those generated by
+-cookie and -target, are ignored by the browser.
+
+The B<-nph> parameter, if set to a true value, will issue the correct
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers, such as Microsoft IIS, which
+expect all their scripts to be NPH.
+
+The B<-status> parameter will set the status of the redirect. HTTP
+defines three different possible redirection status codes:
+
+ 301 Moved Permanently
+ 302 Found
+ 303 See Other
+
+The default if not specified is 302, which means "moved temporarily."
+You may change the status to another status code if you wish. Be
+advised that changing the status to anything other than 301, 302 or
+303 will probably break redirection.
+
+=head2 CREATING THE HTML DOCUMENT HEADER
+
+ print start_html(-title=>'Secrets of the Pyramids',
+ -author=>'fred@capricorn.org',
+ -base=>'true',
+ -target=>'_blank',
+ -meta=>{'keywords'=>'pharaoh secret mummy',
+ 'copyright'=>'copyright 1996 King Tut'},
+ -style=>{'src'=>'/styles/style1.css'},
+ -BGCOLOR=>'blue');
+
+After creating the HTTP header, most CGI scripts will start writing
+out an HTML document. The start_html() routine creates the top of the
+page, along with a lot of optional information that controls the
+page's appearance and behavior.
+
+This method returns a canned HTML header and the opening <body> tag.
+All parameters are optional. In the named parameter form, recognized
+parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
+(see below for the explanation). Any additional parameters you
+provide, such as the unofficial BGCOLOR attribute, are added
+to the <body> tag. Additional parameters must be proceeded by a
+hyphen.
+
+The argument B<-xbase> allows you to provide an HREF for the <base> tag
+different from the current location, as in
+
+ -xbase=>"http://home.mcom.com/"
+
+All relative links will be interpreted relative to this tag.
+
+The argument B<-target> allows you to provide a default target frame
+for all the links and fill-out forms on the page. B<This is a
+non-standard HTTP feature which only works with some browsers!>
+
+ -target=>"answer_window"
+
+All relative links will be interpreted relative to this tag.
+You add arbitrary meta information to the header with the B<-meta>
+argument. This argument expects a reference to a hash
+containing name/value pairs of meta information. These will be turned
+into a series of header <meta> tags that look something like this:
+
+ <meta name="keywords" content="pharaoh secret mummy">
+ <meta name="description" content="copyright 1996 King Tut">
+
+To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
+below.
+
+The B<-style> argument is used to incorporate cascading stylesheets
+into your code. See the section on CASCADING STYLESHEETS for more
+information.
+
+The B<-lang> argument is used to incorporate a language attribute into
+the <html> tag. For example:
+
+ print $q->start_html(-lang=>'fr-CA');
+
+The default if not specified is "en-US" for US English, unless the
+-dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
+lang attribute is left off. You can force the lang attribute to left
+off in other cases by passing an empty string (-lang=>'').
+
+The B<-encoding> argument can be used to specify the character set for
+XHTML. It defaults to iso-8859-1 if not specified.
+
+The B<-declare_xml> argument, when used in conjunction with XHTML,
+will put a <?xml> declaration at the top of the HTML header. The sole
+purpose of this declaration is to declare the character set
+encoding. In the absence of -declare_xml, the output HTML will contain
+a <meta> tag that specifies the encoding, allowing the HTML to pass
+most validators. The default for -declare_xml is false.
+
+You can place other arbitrary HTML elements to the <head> section with the
+B<-head> tag. For example, to place the rarely-used <link> element in the
+head section, use this:
+
+ print start_html(-head=>Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}));
+
+To incorporate multiple HTML elements into the <head> section, just pass an
+array reference:
+
+ print start_html(-head=>[
+ Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}),
+ Link({-rel=>'previous',
+ -href=>'http://www.capricorn.com/s1.html'})
+ ]
+ );
+
+And here's how to create an HTTP-EQUIV <meta> tag:
+
+ print start_html(-head=>meta({-http_equiv => 'Content-Type',
+ -content => 'text/html'}))
+
+
+JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
+to add JavaScript calls to your pages. B<-script> should
+point to a block of text containing JavaScript function definitions.
+This block will be placed within a <script> block inside the HTML (not
+HTTP) header. The block is placed in the header in order to give your
+page a fighting chance of having all its JavaScript functions in place
+even if the user presses the stop button before the page has loaded
+completely. CGI.pm attempts to format the script in such a way that
+JavaScript-naive browsers will not choke on the code: unfortunately
+there are some browsers, such as Chimera for Unix, that get confused
+by it nevertheless.
+
+The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
+code to execute when the page is respectively opened and closed by the
+browser. Usually these parameters are calls to functions defined in the
+B<-script> field:
+
+ $query = CGI->new;
+ print header;
+ $JSCRIPT=<<END;
+ // Ask a silly question
+ function riddle_me_this() {
+ var r = prompt("What walks on four legs in the morning, " +
+ "two legs in the afternoon, " +
+ "and three legs in the evening?");
+ response(r);
+ }
+ // Get a silly answer
+ function response(answer) {
+ if (answer == "man")
+ alert("Right you are!");
+ else
+ alert("Wrong! Guess again.");
+ }
+ END
+ print start_html(-title=>'The Riddle of the Sphinx',
+ -script=>$JSCRIPT);
+
+Use the B<-noScript> parameter to pass some HTML text that will be displayed on
+browsers that do not have JavaScript (or browsers where JavaScript is turned
+off).
+
+The <script> tag, has several attributes including "type" and src.
+The latter is particularly interesting, as it allows you to keep the
+JavaScript code in a file or CGI script rather than cluttering up each
+page with the source. To use these attributes pass a HASH reference
+in the B<-script> parameter containing one or more of -type, -src, or
+-code:
+
+ print $q->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>{-type=>'JAVASCRIPT',
+ -src=>'/javascript/sphinx.js'}
+ );
+
+ print $q->(-title=>'The Riddle of the Sphinx',
+ -script=>{-type=>'PERLSCRIPT',
+ -code=>'print "hello world!\n;"'}
+ );
+
+
+A final feature allows you to incorporate multiple <script> sections into the
+header. Just pass the list of script sections as an array reference.
+this allows you to specify different source files for different dialects
+of JavaScript. Example:
+
+ print $q->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>[
+ { -type => 'text/javascript',
+ -src => '/javascript/utilities10.js'
+ },
+ { -type => 'text/javascript',
+ -src => '/javascript/utilities11.js'
+ },
+ { -type => 'text/jscript',
+ -src => '/javascript/utilities12.js'
+ },
+ { -type => 'text/ecmascript',
+ -src => '/javascript/utilities219.js'
+ }
+ ]
+ );
+
+The option "-language" is a synonym for -type, and is supported for
+backwad compatibility.
+
+The old-style positional parameters are as follows:
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The title
+
+=item 2.
+
+The author's e-mail address (will create a <link rev="MADE"> tag if present
+
+=item 3.
+
+A 'true' flag if you want to include a <base> tag in the header. This
+helps resolve relative addresses to absolute ones when the document is moved,
+but makes the document hierarchy non-portable. Use with care!
+
+=item 4, 5, 6...
+
+Any other parameters you want to include in the <body> tag. This is a good
+place to put HTML extensions, such as colors and wallpaper patterns.
+
+=back
+
+=head2 ENDING THE HTML DOCUMENT:
+
+ print end_html
+
+This ends an HTML document by printing the </body></html> tags.
+
+=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
+
+ $myself = self_url;
+ print q(<a href="$myself">I'm talking to myself.</a>);
+
+self_url() will return a URL, that, when selected, will reinvoke
+this script with all its state information intact. This is most
+useful when you want to jump around within the document using
+internal anchors but you don't want to disrupt the current contents
+of the form(s). Something like this will do the trick.
+
+ $myself = self_url;
+ print "<a href=\"$myself#table1\">See table 1</a>";
+ print "<a href=\"$myself#table2\">See table 2</a>";
+ print "<a href=\"$myself#yourself\">See for yourself</a>";
+
+If you want more control over what's returned, using the B<url()>
+method instead.
+
+You can also retrieve the unprocessed query string with query_string():
+
+ $the_string = query_string;
+
+=head2 OBTAINING THE SCRIPT'S URL
+
+ $full_url = url();
+ $full_url = url(-full=>1); #alternative syntax
+ $relative_url = url(-relative=>1);
+ $absolute_url = url(-absolute=>1);
+ $url_with_path = url(-path_info=>1);
+ $url_with_path_and_query = url(-path_info=>1,-query=>1);
+ $netloc = url(-base => 1);
+
+B<url()> returns the script's URL in a variety of formats. Called
+without any arguments, it returns the full form of the URL, including
+host name and port number
+
+ http://your.host.com/path/to/script.cgi
+
+You can modify this format with the following named arguments:
+
+=over 4
+
+=item B<-absolute>
+
+If true, produce an absolute URL, e.g.
+
+ /path/to/script.cgi
+
+=item B<-relative>
+
+Produce a relative URL. This is useful if you want to reinvoke your
+script with different parameters. For example:
+
+ script.cgi
+
+=item B<-full>
+
+Produce the full URL, exactly as if called without any arguments.
+This overrides the -relative and -absolute arguments.
+
+=item B<-path> (B<-path_info>)
+
+Append the additional path information to the URL. This can be
+combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
+is provided as a synonym.
+
+=item B<-query> (B<-query_string>)
+
+Append the query string to the URL. This can be combined with
+B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
+as a synonym.
+
+=item B<-base>
+
+Generate just the protocol and net location, as in http://www.foo.com:8000
+
+=item B<-rewrite>
+
+If Apache's mod_rewrite is turned on, then the script name and path
+info probably won't match the request that the user sent. Set
+-rewrite=>1 (default) to return URLs that match what the user sent
+(the original request URI). Set -rewrite=>0 to return URLs that match
+the URL after mod_rewrite's rules have run. Because the additional
+path information only makes sense in the context of the rewritten URL,
+-rewrite is set to false when you request path info in the URL.
+
+=back
+
+=head2 MIXING POST AND URL PARAMETERS
+
+ $color = url_param('color');
+
+It is possible for a script to receive CGI parameters in the URL as
+well as in the fill-out form by creating a form that POSTs to a URL
+containing a query string (a "?" mark followed by arguments). The
+B<param()> method will always return the contents of the POSTed
+fill-out form, ignoring the URL's query string. To retrieve URL
+parameters, call the B<url_param()> method. Use it in the same way as
+B<param()>. The main difference is that it allows you to read the
+parameters, but not set them.
+
+
+Under no circumstances will the contents of the URL query string
+interfere with similarly-named CGI parameters in POSTed forms. If you
+try to mix a URL query string with a form submitted with the GET
+method, the results will not be what you expect.
+
+=head1 CREATING STANDARD HTML ELEMENTS:
+
+CGI.pm defines general HTML shortcut methods for most, if not all of
+the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
+HTML element and return a fragment of HTML text that you can then
+print or manipulate as you like. Each shortcut returns a fragment of
+HTML code that you can append to a string, save to a file, or, most
+commonly, print out so that it displays in the browser window.
+
+This example shows how to use the HTML methods:
+
+ print $q->blockquote(
+ "Many years ago on the island of",
+ $q->a({href=>"http://crete.org/"},"Crete"),
+ "there lived a Minotaur named",
+ $q->strong("Fred."),
+ ),
+ $q->hr;
+
+This results in the following HTML code (extra newlines have been
+added for readability):
+
+ <blockquote>
+ Many years ago on the island of
+ <a href="http://crete.org/">Crete</a> there lived
+ a minotaur named <strong>Fred.</strong>
+ </blockquote>
+ <hr>
+
+If you find the syntax for calling the HTML shortcuts awkward, you can
+import them into your namespace and dispense with the object syntax
+completely (see the next section for more details):
+
+ use CGI ':standard';
+ print blockquote(
+ "Many years ago on the island of",
+ a({href=>"http://crete.org/"},"Crete"),
+ "there lived a minotaur named",
+ strong("Fred."),
+ ),
+ hr;
+
+=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
+
+The HTML methods will accept zero, one or multiple arguments. If you
+provide no arguments, you get a single tag:
+
+ print hr; # <hr>
+
+If you provide one or more string arguments, they are concatenated
+together with spaces and placed between opening and closing tags:
+
+ print h1("Chapter","1"); # <h1>Chapter 1</h1>"
+
+If the first argument is a hash reference, then the keys
+and values of the hash become the HTML tag's attributes:
+
+ print a({-href=>'fred.html',-target=>'_new'},
+ "Open a new frame");
+
+ <a href="fred.html",target="_new">Open a new frame</a>
+
+You may dispense with the dashes in front of the attribute names if
+you prefer:
+
+ print img {src=>'fred.gif',align=>'LEFT'};
+
+ <img align="LEFT" src="fred.gif">
+
+Sometimes an HTML tag attribute has no argument. For example, ordered
+lists can be marked as COMPACT. The syntax for this is an argument that
+that points to an undef string:
+
+ print ol({compact=>undef},li('one'),li('two'),li('three'));
+
+Prior to CGI.pm version 2.41, providing an empty ('') string as an
+attribute argument was the same as providing undef. However, this has
+changed in order to accommodate those who want to create tags of the form
+<img alt="">. The difference is shown in these two pieces of code:
+
+ CODE RESULT
+ img({alt=>undef}) <img alt>
+ img({alt=>''}) <img alt="">
+
+=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
+
+One of the cool features of the HTML shortcuts is that they are
+distributive. If you give them an argument consisting of a
+B<reference> to a list, the tag will be distributed across each
+element of the list. For example, here's one way to make an ordered
+list:
+
+ print ul(
+ li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
+ );
+
+This example will result in HTML output that looks like this:
+
+ <ul>
+ <li type="disc">Sneezy</li>
+ <li type="disc">Doc</li>
+ <li type="disc">Sleepy</li>
+ <li type="disc">Happy</li>
+ </ul>
+
+This is extremely useful for creating tables. For example:
+
+ print table({-border=>undef},
+ caption('When Should You Eat Your Vegetables?'),
+ Tr({-align=>'CENTER',-valign=>'TOP'},
+ [
+ th(['Vegetable', 'Breakfast','Lunch','Dinner']),
+ td(['Tomatoes' , 'no', 'yes', 'yes']),
+ td(['Broccoli' , 'no', 'no', 'yes']),
+ td(['Onions' , 'yes','yes', 'yes'])
+ ]
+ )
+ );
+
+=head2 HTML SHORTCUTS AND LIST INTERPOLATION
+
+Consider this bit of code:
+
+ print blockquote(em('Hi'),'mom!'));
+
+It will ordinarily return the string that you probably expect, namely:
+
+ <blockquote><em>Hi</em> mom!</blockquote>
+
+Note the space between the element "Hi" and the element "mom!".
+CGI.pm puts the extra space there using array interpolation, which is
+controlled by the magic $" variable. Sometimes this extra space is
+not what you want, for example, when you are trying to align a series
+of images. In this case, you can simply change the value of $" to an
+empty string.
+
+ {
+ local($") = '';
+ print blockquote(em('Hi'),'mom!'));
+ }
+
+I suggest you put the code in a block as shown here. Otherwise the
+change to $" will affect all subsequent code until you explicitly
+reset it.
+
+=head2 NON-STANDARD HTML SHORTCUTS
+
+A few HTML tags don't follow the standard pattern for various
+reasons.
+
+B<comment()> generates an HTML comment (<!-- comment -->). Call it
+like
+
+ print comment('here is my comment');
+
+Because of conflicts with built-in Perl functions, the following functions
+begin with initial caps:
+
+ Select
+ Tr
+ Link
+ Delete
+ Accept
+ Sub
+
+In addition, start_html(), end_html(), start_form(), end_form(),
+start_multipart_form() and all the fill-out form tags are special.
+See their respective sections.
+
+=head2 AUTOESCAPING HTML
+
+By default, all HTML that is emitted by the form-generating functions
+is passed through a function called escapeHTML():
+
+=over 4
+
+=item $escaped_string = escapeHTML("unescaped string");
+
+Escape HTML formatting characters in a string.
+
+=back
+
+Provided that you have specified a character set of ISO-8859-1 (the
+default), the standard HTML escaping rules will be used. The "<"
+character becomes "&lt;", ">" becomes "&gt;", "&" becomes "&amp;", and
+the quote character becomes "&quot;". In addition, the hexadecimal
+0x8b and 0x9b characters, which some browsers incorrectly interpret
+as the left and right angle-bracket characters, are replaced by their
+numeric character entities ("&#8249" and "&#8250;"). If you manually change
+the charset, either by calling the charset() method explicitly or by
+passing a -charset argument to header(), then B<all> characters will
+be replaced by their numeric entities, since CGI.pm has no lookup
+table for all the possible encodings.
+
+C<escapeHTML()> expects the supplied string to be a character string. This means you
+should Encode::decode data received from "outside" and Encode::encode your
+strings before sending them back outside. If your source code UTF-8 encoded and
+you want to upgrade string literals in your source to character strings, you
+can use "use utf8". See L<perlunitut>, L<perlunifaq> and L<perlunicode> for more
+information on how Perl handles the difference between bytes and characters.
+
+The automatic escaping does not apply to other shortcuts, such as
+h1(). You should call escapeHTML() yourself on untrusted data in
+order to protect your pages against nasty tricks that people may enter
+into guestbooks, etc.. To change the character set, use charset().
+To turn autoescaping off completely, use autoEscape(0):
+
+=over 4
+
+=item $charset = charset([$charset]);
+
+Get or set the current character set.
+
+=item $flag = autoEscape([$flag]);
+
+Get or set the value of the autoescape flag.
+
+=back
+
+=head2 PRETTY-PRINTING HTML
+
+By default, all the HTML produced by these functions comes out as one
+long line without carriage returns or indentation. This is yuck, but
+it does reduce the size of the documents by 10-20%. To get
+pretty-printed output, please use L<CGI::Pretty>, a subclass
+contributed by Brian Paulsen.
+
+=head1 CREATING FILL-OUT FORMS:
+
+I<General note> The various form-creating methods all return strings
+to the caller, containing the tag or tags that will create the requested
+form element. You are responsible for actually printing out these strings.
+It's set up this way so that you can place formatting tags
+around the form elements.
+
+I<Another note> The default values that you specify for the forms are only
+used the B<first> time the script is invoked (when there is no query
+string). On subsequent invocations of the script (when there is a query
+string), the former values are used even if they are blank.
+
+If you want to change the value of a field from its previous value, you have two
+choices:
+
+(1) call the param() method to set it.
+
+(2) use the -override (alias -force) parameter (a new feature in version 2.15).
+This forces the default value to be used, regardless of the previous value:
+
+ print textfield(-name=>'field_name',
+ -default=>'starting value',
+ -override=>1,
+ -size=>50,
+ -maxlength=>80);
+
+I<Yet another note> By default, the text and labels of form elements are
+escaped according to HTML rules. This means that you can safely use
+"<CLICK ME>" as the label for a button. However, it also interferes with
+your ability to incorporate special HTML character sequences, such as &Aacute;,
+into your fields. If you wish to turn off automatic escaping, call the
+autoEscape() method with a false value immediately after creating the CGI object:
+
+ $query = CGI->new;
+ $query->autoEscape(0);
+
+Note that autoEscape() is exclusively used to effect the behavior of how some
+CGI.pm HTML generation fuctions handle escaping. Calling escapeHTML()
+explicitly will always escape the HTML.
+
+I<A Lurking Trap!> Some of the form-element generating methods return
+multiple tags. In a scalar context, the tags will be concatenated
+together with spaces, or whatever is the current value of the $"
+global. In a list context, the methods will return a list of
+elements, allowing you to modify them if you wish. Usually you will
+not notice this behavior, but beware of this:
+
+ printf("%s\n",end_form())
+
+end_form() produces several tags, and only the first of them will be
+printed because the format only expects one value.
+
+<p>
+
+
+=head2 CREATING AN ISINDEX TAG
+
+ print isindex(-action=>$action);
+
+ -or-
+
+ print isindex($action);
+
+Prints out an <isindex> tag. Not very exciting. The parameter
+-action specifies the URL of the script to process the query. The
+default is to process the query with the current script.
+
+=head2 STARTING AND ENDING A FORM
+
+ print start_form(-method=>$method,
+ -action=>$action,
+ -enctype=>$encoding);
+ <... various form stuff ...>
+ print end_form;
+
+ -or-
+
+ print start_form($method,$action,$encoding);
+ <... various form stuff ...>
+ print end_form;
+
+start_form() will return a <form> tag with the optional method,
+action and form encoding that you specify. The defaults are:
+
+ method: POST
+ action: this script
+ enctype: application/x-www-form-urlencoded for non-XHTML
+ multipart/form-data for XHTML, see mulitpart/form-data below.
+
+end_form() returns the closing </form> tag.
+
+Start_form()'s enctype argument tells the browser how to package the various
+fields of the form before sending the form to the server. Two
+values are possible:
+
+B<Note:> These methods were previously named startform() and endform().
+These methods are now DEPRECATED.
+Please use start_form() and end_form() instead.
+
+=over 4
+
+=item B<application/x-www-form-urlencoded>
+
+This is the older type of encoding. It is compatible with many CGI scripts and is
+suitable for short fields containing text data. For your
+convenience, CGI.pm stores the name of this encoding
+type in B<&CGI::URL_ENCODED>.
+
+=item B<multipart/form-data>
+
+This is the newer type of encoding.
+It is suitable for forms that contain very large fields or that
+are intended for transferring binary data. Most importantly,
+it enables the "file upload" feature. For
+your convenience, CGI.pm stores the name of this encoding type
+in B<&CGI::MULTIPART>
+
+Forms that use this type of encoding are not easily interpreted
+by CGI scripts unless they use CGI.pm or another library designed
+to handle them.
+
+If XHTML is activated (the default), then forms will be automatically
+created using this type of encoding.
+
+=back
+
+The start_form() method uses the older form of encoding by
+default unless XHTML is requested. If you want to use the
+newer form of encoding by default, you can call
+B<start_multipart_form()> instead of B<start_form()>. The
+method B<end_multipart_form()> is an alias to B<end_form()>.
+
+JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
+for use with JavaScript. The -name parameter gives the
+form a name so that it can be identified and manipulated by
+JavaScript functions. -onSubmit should point to a JavaScript
+function that will be executed just before the form is submitted to your
+server. You can use this opportunity to check the contents of the form
+for consistency and completeness. If you find something wrong, you
+can put up an alert box or maybe fix things up yourself. You can
+abort the submission by returning false from this function.
+
+Usually the bulk of JavaScript functions are defined in a <script>
+block in the HTML header and -onSubmit points to one of these function
+call. See start_html() for details.
+
+=head2 FORM ELEMENTS
+
+After starting a form, you will typically create one or more
+textfields, popup menus, radio groups and other form elements. Each
+of these elements takes a standard set of named arguments. Some
+elements also have optional arguments. The standard arguments are as
+follows:
+
+=over 4
+
+=item B<-name>
+
+The name of the field. After submission this name can be used to
+retrieve the field's value using the param() method.
+
+=item B<-value>, B<-values>
+
+The initial value of the field which will be returned to the script
+after form submission. Some form elements, such as text fields, take
+a single scalar -value argument. Others, such as popup menus, take a
+reference to an array of values. The two arguments are synonyms.
+
+=item B<-tabindex>
+
+A numeric value that sets the order in which the form element receives
+focus when the user presses the tab key. Elements with lower values
+receive focus first.
+
+=item B<-id>
+
+A string identifier that can be used to identify this element to
+JavaScript and DHTML.
+
+=item B<-override>
+
+A boolean, which, if true, forces the element to take on the value
+specified by B<-value>, overriding the sticky behavior described
+earlier for the B<-nosticky> pragma.
+
+=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
+
+These are used to assign JavaScript event handlers. See the
+JavaScripting section for more details.
+
+=back
+
+Other common arguments are described in the next section. In addition
+to these, all attributes described in the HTML specifications are
+supported.
+
+=head2 CREATING A TEXT FIELD
+
+ print textfield(-name=>'field_name',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print textfield('field_name','starting value',50,80);
+
+textfield() will return a text input field.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the default starting value for the field
+contents (-value, formerly known as -default).
+
+=item 3.
+
+The optional third parameter is the size of the field in
+ characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+ field will accept (-maxlength).
+
+=back
+
+As with all these methods, the field will be initialized with its
+previous contents from earlier invocations of the script.
+When the form is processed, the value of the text field can be
+retrieved with:
+
+ $value = param('foo');
+
+If you want to reset it from its initial value after the script has been
+called once, you can do so like this:
+
+ param('foo',"I'm taking over this value!");
+
+=head2 CREATING A BIG TEXT FIELD
+
+ print textarea(-name=>'foo',
+ -default=>'starting value',
+ -rows=>10,
+ -columns=>50);
+
+ -or
+
+ print textarea('foo','starting value',10,50);
+
+textarea() is just like textfield, but it allows you to specify
+rows and columns for a multiline text entry box. You can provide
+a starting value for the field, which can be long and contain
+multiple lines.
+
+=head2 CREATING A PASSWORD FIELD
+
+ print password_field(-name=>'secret',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print password_field('secret','starting value',50,80);
+
+password_field() is identical to textfield(), except that its contents
+will be starred out on the web page.
+
+=head2 CREATING A FILE UPLOAD FIELD
+
+ print filefield(-name=>'uploaded_file',
+ -default=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print filefield('uploaded_file','starting value',50,80);
+
+filefield() will return a file upload field.
+In order to take full advantage of this I<you must use the new
+multipart encoding scheme> for the form. You can do this either
+by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
+or by calling the new method B<start_multipart_form()> instead of
+vanilla B<start_form()>.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the starting value for the field contents
+to be used as the default file name (-default).
+
+For security reasons, browsers don't pay any attention to this field,
+and so the starting value will always be blank. Worse, the field
+loses its "sticky" behavior and forgets its previous contents. The
+starting value field is called for in the HTML specification, however,
+and possibly some browser will eventually provide support for it.
+
+=item 3.
+
+The optional third parameter is the size of the field in
+characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+field will accept (-maxlength).
+
+=back
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
+recognized. See textfield() for details.
+
+=head2 PROCESSING A FILE UPLOAD FIELD
+
+=head3 Basics
+
+When the form is processed, you can retrieve an L<IO::Handle> compatibile
+handle for a file upload field like this:
+
+ $lightweight_fh = $q->upload('field_name');
+
+ # undef may be returned if it's not a valid file handle
+ if (defined $lightweight_fh) {
+ # Upgrade the handle to one compatible with IO::Handle:
+ my $io_handle = $lightweight_fh->handle;
+
+ open (OUTFILE,'>>','/usr/local/web/users/feedback');
+ while ($bytesread = $io_handle->read($buffer,1024)) {
+ print OUTFILE $buffer;
+ }
+ }
+
+In a list context, upload() will return an array of filehandles.
+This makes it possible to process forms that use the same name for
+multiple upload fields.
+
+If you want the entered file name for the file, you can just call param():
+
+ $filename = $q->param('field_name');
+
+Different browsers will return slightly different things for the
+name. Some browsers return the filename only. Others return the full
+path to the file, using the path conventions of the user's machine.
+Regardless, the name returned is always the name of the file on the
+I<user's> machine, and is unrelated to the name of the temporary file
+that CGI.pm creates during upload spooling (see below).
+
+When a file is uploaded the browser usually sends along some
+information along with it in the format of headers. The information
+usually includes the MIME content type. To
+retrieve this information, call uploadInfo(). It returns a reference to
+a hash containing all the document headers.
+
+ $filename = $q->param('uploaded_file');
+ $type = $q->uploadInfo($filename)->{'Content-Type'};
+ unless ($type eq 'text/html') {
+ die "HTML FILES ONLY!";
+ }
+
+If you are using a machine that recognizes "text" and "binary" data
+modes, be sure to understand when and how to use them (see the Camel book).
+Otherwise you may find that binary files are corrupted during file
+uploads.
+
+=head3 Accessing the temp files directly
+
+When processing an uploaded file, CGI.pm creates a temporary file on your hard
+disk and passes you a file handle to that file. After you are finished with the
+file handle, CGI.pm unlinks (deletes) the temporary file. If you need to you
+can access the temporary file directly. You can access the temp file for a file
+upload by passing the file name to the tmpFileName() method:
+
+ $filename = $query->param('uploaded_file');
+ $tmpfilename = $query->tmpFileName($filename);
+
+The temporary file will be deleted automatically when your program exits unless
+you manually rename it. On some operating systems (such as Windows NT), you
+will need to close the temporary file's filehandle before your program exits.
+Otherwise the attempt to delete the temporary file will fail.
+
+=head3 Handling interrupted file uploads
+
+There are occasionally problems involving parsing the uploaded file.
+This usually happens when the user presses "Stop" before the upload is
+finished. In this case, CGI.pm will return undef for the name of the
+uploaded file and set I<cgi_error()> to the string "400 Bad request
+(malformed multipart POST)". This error message is designed so that
+you can incorporate it into a status code to be sent to the browser.
+Example:
+
+ $file = $q->upload('uploaded_file');
+ if (!$file && $q->cgi_error) {
+ print $q->header(-status=>$q->cgi_error);
+ exit 0;
+ }
+
+You are free to create a custom HTML page to complain about the error,
+if you wish.
+
+=head3 Progress bars for file uploads and avoiding temp files
+
+CGI.pm gives you low-level access to file upload management through
+a file upload hook. You can use this feature to completely turn off
+the temp file storage of file uploads, or potentially write your own
+file upload progess meter.
+
+This is much like the UPLOAD_HOOK facility available in L<Apache::Request>, with
+the exception that the first argument to the callback is an L<Apache::Upload>
+object, here it's the remote filename.
+
+ $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
+
+ sub hook {
+ my ($filename, $buffer, $bytes_read, $data) = @_;
+ print "Read $bytes_read bytes of $filename\n";
+ }
+
+The C<< $data >> field is optional; it lets you pass configuration
+information (e.g. a database handle) to your hook callback.
+
+The C<< $use_tempfile >> field is a flag that lets you turn on and off
+CGI.pm's use of a temporary disk-based file during file upload. If you
+set this to a FALSE value (default true) then $q->param('uploaded_file')
+will no longer work, and the only way to get at the uploaded data is
+via the hook you provide.
+
+If using the function-oriented interface, call the CGI::upload_hook()
+method before calling param() or any other CGI functions:
+
+ CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
+
+This method is not exported by default. You will have to import it
+explicitly if you wish to use it without the CGI:: prefix.
+
+=head3 Troubleshooting file uploads on Windows
+
+If you are using CGI.pm on a Windows platform and find that binary
+files get slightly larger when uploaded but that text files remain the
+same, then you have forgotten to activate binary mode on the output
+filehandle. Be sure to call binmode() on any handle that you create
+to write the uploaded file to disk.
+
+=head3 Older ways to process file uploads
+
+( This section is here for completeness. if you are building a new application with CGI.pm, you can skip it. )
+
+The original way to process file uploads with CGI.pm was to use param(). The
+value it returns has a dual nature as both a file name and a lightweight
+filehandle. This dual nature is problematic if you following the recommended
+practice of having C<use strict> in your code. Perl will complain when you try
+to use a string as a filehandle. More seriously, it is possible for the remote
+user to type garbage into the upload field, in which case what you get from
+param() is not a filehandle at all, but a string.
+
+To solve this problem the upload() method was added, which always returns a
+lightweight filehandle. This generally works well, but will have trouble
+interoperating with some other modules because the file handle is not derived
+from L<IO::Handle>. So that brings us to current recommedation given above,
+which is to call the handle() method on the file handle returned by upload().
+That upgrades the handle to an IO::Handle. It's a big win for compatibility for
+a small penalty of loading IO::Handle the first time you call it.
+
+
+=head2 CREATING A POPUP MENU
+
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie');
+
+ -or-
+
+ %labels = ('eenie'=>'your first choice',
+ 'meenie'=>'your second choice',
+ 'minie'=>'your third choice');
+ %attributes = ('eenie'=>{'class'=>'class of first choice'});
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie',\%labels,\%attributes);
+
+ -or (named parameter style)-
+
+ print popup_menu(-name=>'menu_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>['meenie','minie'],
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+popup_menu() creates a menu.
+
+=over 4
+
+=item 1.
+
+The required first argument is the menu's name (-name).
+
+=item 2.
+
+The required second argument (-values) is an array B<reference>
+containing the list of menu items in the menu. You can pass the
+method an anonymous array, as shown in the example, or a reference to
+a named array, such as "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+menu choice. If not specified, the first item will be the default.
+The values of the previous choice will be maintained across
+queries. Pass an array reference to select multiple defaults.
+
+=item 4.
+
+The optional fourth parameter (-labels) is provided for people who
+want to use different values for the user-visible label inside the
+popup menu and the value returned to your script. It's a pointer to an
+hash relating menu values to user-visible labels. If you
+leave this parameter blank, the menu values will be displayed by
+default. (You can also leave a label undefined if you want to).
+
+=item 5.
+
+The optional fifth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
+attribute's value as the value.
+
+=back
+
+When the form is processed, the selected value of the popup menu can
+be retrieved using:
+
+ $popup_menu_value = param('menu_name');
+
+=head2 CREATING AN OPTION GROUP
+
+Named parameter style
+
+ print popup_menu(-name=>'menu_name',
+ -values=>[qw/eenie meenie minie/,
+ optgroup(-name=>'optgroup_name',
+ -values => ['moe','catch'],
+ -attributes=>{'catch'=>{'class'=>'red'}})],
+ -labels=>{'eenie'=>'one',
+ 'meenie'=>'two',
+ 'minie'=>'three'},
+ -default=>'meenie');
+
+ Old style
+ print popup_menu('menu_name',
+ ['eenie','meenie','minie',
+ optgroup('optgroup_name', ['moe', 'catch'],
+ {'catch'=>{'class'=>'red'}})],'meenie',
+ {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
+
+optgroup() creates an option group within a popup menu.
+
+=over 4
+
+=item 1.
+
+The required first argument (B<-name>) is the label attribute of the
+optgroup and is B<not> inserted in the parameter list of the query.
+
+=item 2.
+
+The required second argument (B<-values>) is an array reference
+containing the list of menu items in the menu. You can pass the
+method an anonymous array, as shown in the example, or a reference
+to a named array, such as \@foo. If you pass a HASH reference,
+the keys will be used for the menu values, and the values will be
+used for the menu labels (see -labels below).
+
+=item 3.
+
+The optional third parameter (B<-labels>) allows you to pass a reference
+to a hash containing user-visible labels for one or more
+of the menu items. You can use this when you want the user to see one
+menu string, but have the browser return your program a different one.
+If you don't specify this, the value string will be used instead
+("eenie", "meenie" and "minie" in this example). This is equivalent
+to using a hash reference for the -values parameter.
+
+=item 4.
+
+An optional fourth parameter (B<-labeled>) can be set to a true value
+and indicates that the values should be used as the label attribute
+for each option element within the optgroup.
+
+=item 5.
+
+An optional fifth parameter (-novals) can be set to a true value and
+indicates to suppress the val attribute in each option element within
+the optgroup.
+
+See the discussion on optgroup at W3C
+(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
+for details.
+
+=item 6.
+
+An optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
+attribute's value as the value.
+
+=back
+
+=head2 CREATING A SCROLLING LIST
+
+ print scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
+ -or-
+
+ print scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true',
+ \%labels,%attributes);
+
+ -or-
+
+ print scrolling_list(-name=>'list_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -size=>5,
+ -multiple=>'true',
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+scrolling_list() creates a scrolling list.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the list name (-name) and values
+(-values). As in the popup menu, the second argument should be an
+array reference.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be selected by default, or can be a
+single value to select. If this argument is missing or undefined,
+then nothing is selected when the list first appears. In the named
+parameter version, you can use the synonym "-defaults" for this
+parameter.
+
+=item 3.
+
+The optional fourth argument is the size of the list (-size).
+
+=item 4.
+
+The optional fifth argument can be set to true to allow multiple
+simultaneous selections (-multiple). Otherwise only one selection
+will be allowed at a time.
+
+=item 5.
+
+The optional sixth argument is a pointer to a hash
+containing long user-visible labels for the list items (-labels).
+If not provided, the values will be displayed.
+
+=item 6.
+
+The optional sixth parameter (-attributes) is provided to assign
+any of the common HTML attributes to an individual menu item. It's
+a pointer to a hash relating menu values to another
+hash with the attribute's name as the key and the
+attribute's value as the value.
+
+When this form is processed, all selected list items will be returned as
+a list under the parameter name 'list_name'. The values of the
+selected items can be retrieved with:
+
+ @selected = param('list_name');
+
+=back
+
+=head2 CREATING A GROUP OF RELATED CHECKBOXES
+
+ print checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -linebreak=>'true',
+ -disabled => ['moe'],
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+ print checkbox_group('group_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],'true',\%labels,
+ {'moe'=>{'class'=>'red'}});
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+
+checkbox_group() creates a list of checkboxes that are related
+by the same name.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the checkbox name and values,
+respectively (-name and -values). As in the popup menu, the second
+argument should be an array reference. These values are used for the
+user-readable labels printed next to the checkboxes as well as for the
+values passed to your script in the query string.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be checked by default, or can be a
+single value to checked. If this argument is missing or undefined,
+then nothing is selected when the list first appears.
+
+=item 3.
+
+The optional fourth argument (-linebreak) can be set to true to place
+line breaks between the checkboxes so that they appear as a vertical
+list. Otherwise, they will be strung together on a horizontal line.
+
+=back
+
+
+The optional B<-labels> argument is a pointer to a hash
+relating the checkbox values to the user-visible labels that will be
+printed next to them. If not provided, the values will be used as the
+default.
+
+
+The optional parameters B<-rows>, and B<-columns> cause
+checkbox_group() to return an HTML3 compatible table containing the
+checkbox group formatted with the specified number of rows and
+columns. You can provide just the -columns parameter if you wish;
+checkbox_group will calculate the correct number of rows for you.
+
+The option B<-disabled> takes an array of checkbox values and disables
+them by greying them out (this may not be supported by all browsers).
+
+The optional B<-attributes> argument is provided to assign any of the
+common HTML attributes to an individual menu item. It's a pointer to
+a hash relating menu values to another hash
+with the attribute's name as the key and the attribute's value as the
+value.
+
+The optional B<-tabindex> argument can be used to control the order in which
+radio buttons receive focus when the user presses the tab button. If
+passed a scalar numeric value, the first element in the group will
+receive this tab index and subsequent elements will be incremented by
+one. If given a reference to an array of radio button values, then
+the indexes will be jiggered so that the order specified in the array
+will correspond to the tab order. You can also pass a reference to a
+hash in which the hash keys are the radio button values and the values
+are the tab indexes of each button. Examples:
+
+ -tabindex => 100 # this group starts at index 100 and counts up
+ -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
+ -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
+When the form is processed, all checked boxes will be returned as
+a list under the parameter name 'group_name'. The values of the
+"on" checkboxes can be retrieved with:
+
+ @turned_on = param('group_name');
+
+The value returned by checkbox_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = checkbox_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+=head2 CREATING A STANDALONE CHECKBOX
+
+ print checkbox(-name=>'checkbox_name',
+ -checked=>1,
+ -value=>'ON',
+ -label=>'CLICK ME');
+
+ -or-
+
+ print checkbox('checkbox_name','checked','ON','CLICK ME');
+
+checkbox() is used to create an isolated checkbox that isn't logically
+related to any others.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first parameter is the required name for the checkbox (-name). It
+will also be used for the user-readable label printed next to the
+checkbox.
+
+=item 2.
+
+The optional second parameter (-checked) specifies that the checkbox
+is turned on by default. Synonyms are -selected and -on.
+
+=item 3.
+
+The optional third parameter (-value) specifies the value of the
+checkbox when it is checked. If not provided, the word "on" is
+assumed.
+
+=item 4.
+
+The optional fourth parameter (-label) is the user-readable label to
+be attached to the checkbox. If not provided, the checkbox name is
+used.
+
+=back
+
+The value of the checkbox can be retrieved using:
+
+ $turned_on = param('checkbox_name');
+
+=head2 CREATING A RADIO BUTTON GROUP
+
+ print radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>'meenie',
+ -linebreak=>'true',
+ -labels=>\%labels,
+ -attributes=>\%attributes);
+
+ -or-
+
+ print radio_group('group_name',['eenie','meenie','minie'],
+ 'meenie','true',\%labels,\%attributes);
+
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+radio_group() creates a set of logically-related radio buttons
+(turning one member of the group on turns the others off)
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is the name of the group and is required (-name).
+
+=item 2.
+
+The second argument (-values) is the list of values for the radio
+buttons. The values and the labels that appear on the page are
+identical. Pass an array I<reference> in the second argument, either
+using an anonymous array, as shown, or by referencing a named array as
+in "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+button to turn on. If not specified, the first item will be the
+default. You can provide a nonexistent button name, such as "-" to
+start up with no buttons selected.
+
+=item 4.
+
+The optional fourth parameter (-linebreak) can be set to 'true' to put
+line breaks between the buttons, creating a vertical list.
+
+=item 5.
+
+The optional fifth parameter (-labels) is a pointer to an associative
+array relating the radio button values to user-visible labels to be
+used in the display. If not provided, the values themselves are
+displayed.
+
+=back
+
+
+All modern browsers can take advantage of the optional parameters
+B<-rows>, and B<-columns>. These parameters cause radio_group() to
+return an HTML3 compatible table containing the radio group formatted
+with the specified number of rows and columns. You can provide just
+the -columns parameter if you wish; radio_group will calculate the
+correct number of rows for you.
+
+To include row and column headings in the returned table, you
+can use the B<-rowheaders> and B<-colheaders> parameters. Both
+of these accept a pointer to an array of headings to use.
+The headings are just decorative. They don't reorganize the
+interpretation of the radio buttons -- they're still a single named
+unit.
+
+The optional B<-tabindex> argument can be used to control the order in which
+radio buttons receive focus when the user presses the tab button. If
+passed a scalar numeric value, the first element in the group will
+receive this tab index and subsequent elements will be incremented by
+one. If given a reference to an array of radio button values, then
+the indexes will be jiggered so that the order specified in the array
+will correspond to the tab order. You can also pass a reference to a
+hash in which the hash keys are the radio button values and the values
+are the tab indexes of each button. Examples:
+
+ -tabindex => 100 # this group starts at index 100 and counts up
+ -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
+ -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
+
+
+The optional B<-attributes> argument is provided to assign any of the
+common HTML attributes to an individual menu item. It's a pointer to
+a hash relating menu values to another hash
+with the attribute's name as the key and the attribute's value as the
+value.
+
+The optional B<-labelattributes> argument will contain attributes
+attached to the <label> element that surrounds each button.
+
+When the form is processed, the selected radio button can
+be retrieved using:
+
+ $which_radio_button = param('group_name');
+
+The value returned by radio_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = radio_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+=head2 CREATING A SUBMIT BUTTON
+
+ print submit(-name=>'button_name',
+ -value=>'value');
+
+ -or-
+
+ print submit('button_name','value');
+
+submit() will create the query submission button. Every form
+should have one of these.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is optional. You can give the button a
+name if you have several submission buttons in your form and you want
+to distinguish between them.
+
+=item 2.
+
+The second argument (-value) is also optional. This gives the button
+a value that will be passed to your script in the query string. The
+name will also be used as the user-visible label.
+
+=item 3.
+
+You can use -label as an alias for -value. I always get confused
+about which of -name and -value changes the user-visible label on the
+button.
+
+=back
+
+You can figure out which button was pressed by using different
+values for each one:
+
+ $which_one = param('button_name');
+
+=head2 CREATING A RESET BUTTON
+
+ print reset
+
+reset() creates the "reset" button. Note that it restores the
+form to its value from the last time the script was called,
+NOT necessarily to the defaults.
+
+Note that this conflicts with the Perl reset() built-in. Use
+CORE::reset() to get the original reset function.
+
+=head2 CREATING A DEFAULT BUTTON
+
+ print defaults('button_label')
+
+defaults() creates a button that, when invoked, will cause the
+form to be completely reset to its defaults, wiping out all the
+changes the user ever made.
+
+=head2 CREATING A HIDDEN FIELD
+
+ print hidden(-name=>'hidden_name',
+ -default=>['value1','value2'...]);
+
+ -or-
+
+ print hidden('hidden_name','value1','value2'...);
+
+hidden() produces a text field that can't be seen by the user. It
+is useful for passing state variable information from one invocation
+of the script to the next.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is required and specifies the name of this
+field (-name).
+
+=item 2.
+
+The second argument is also required and specifies its value
+(-default). In the named parameter style of calling, you can provide
+a single value here or a reference to a whole list
+
+=back
+
+Fetch the value of a hidden field this way:
+
+ $hidden_value = param('hidden_name');
+
+Note, that just like all the other form elements, the value of a
+hidden field is "sticky". If you want to replace a hidden field with
+some other values after the script has been called once you'll have to
+do it manually:
+
+ param('hidden_name','new','values','here');
+
+=head2 CREATING A CLICKABLE IMAGE BUTTON
+
+ print image_button(-name=>'button_name',
+ -src=>'/source/URL',
+ -align=>'MIDDLE');
+
+ -or-
+
+ print image_button('button_name','/source/URL','MIDDLE');
+
+image_button() produces a clickable image. When it's clicked on the
+position of the click is returned to your script as "button_name.x"
+and "button_name.y", where "button_name" is the name you've assigned
+to it.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is required and specifies the name of this
+field.
+
+=item 2.
+
+The second argument (-src) is also required and specifies the URL
+
+=item 3.
+The third option (-align, optional) is an alignment type, and may be
+TOP, BOTTOM or MIDDLE
+
+=back
+
+Fetch the value of the button this way:
+ $x = param('button_name.x');
+ $y = param('button_name.y');
+
+=head2 CREATING A JAVASCRIPT ACTION BUTTON
+
+ print button(-name=>'button_name',
+ -value=>'user visible label',
+ -onClick=>"do_something()");
+
+ -or-
+
+ print button('button_name',"user visible value","do_something()");
+
+button() produces an C<< <input> >> tag with C<type="button">. When it's
+pressed the fragment of JavaScript code pointed to by the B<-onClick> parameter
+will be executed.
+
+=head1 HTTP COOKIES
+
+Browsers support a so-called "cookie" designed to help maintain state
+within a browser session. CGI.pm has several methods that support
+cookies.
+
+A cookie is a name=value pair much like the named parameters in a CGI
+query string. CGI scripts create one or more cookies and send
+them to the browser in the HTTP header. The browser maintains a list
+of cookies that belong to a particular Web server, and returns them
+to the CGI script during subsequent interactions.
+
+In addition to the required name=value pair, each cookie has several
+optional attributes:
+
+=over 4
+
+=item 1. an expiration time
+
+This is a time/date string (in a special GMT format) that indicates
+when a cookie expires. The cookie will be saved and returned to your
+script until this expiration date is reached if the user exits
+the browser and restarts it. If an expiration date isn't specified, the cookie
+will remain active until the user quits the browser.
+
+=item 2. a domain
+
+This is a partial or complete domain name for which the cookie is
+valid. The browser will return the cookie to any host that matches
+the partial domain name. For example, if you specify a domain name
+of ".capricorn.com", then the browser will return the cookie to
+Web servers running on any of the machines "www.capricorn.com",
+"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
+must contain at least two periods to prevent attempts to match
+on top level domains like ".edu". If no domain is specified, then
+the browser will only return the cookie to servers on the host the
+cookie originated from.
+
+=item 3. a path
+
+If you provide a cookie path attribute, the browser will check it
+against your script's URL before returning the cookie. For example,
+if you specify the path "/cgi-bin", then the cookie will be returned
+to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
+and "/cgi-bin/customer_service/complain.pl", but not to the script
+"/cgi-private/site_admin.pl". By default, path is set to "/", which
+causes the cookie to be sent to any CGI script on your site.
+
+=item 4. a "secure" flag
+
+If the "secure" attribute is set, the cookie will only be sent to your
+script if the CGI request is occurring on a secure channel, such as SSL.
+
+=back
+
+The interface to HTTP cookies is the B<cookie()> method:
+
+ $cookie = cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'+1h',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+ print header(-cookie=>$cookie);
+
+B<cookie()> creates a new cookie. Its parameters include:
+
+=over 4
+
+=item B<-name>
+
+The name of the cookie (required). This can be any string at all.
+Although browsers limit their cookie names to non-whitespace
+alphanumeric characters, CGI.pm removes this restriction by escaping
+and unescaping cookies behind the scenes.
+
+=item B<-value>
+
+The value of the cookie. This can be any scalar value,
+array reference, or even hash reference. For example,
+you can store an entire hash into a cookie this way:
+
+ $cookie=cookie(-name=>'family information',
+ -value=>\%childrens_ages);
+
+=item B<-path>
+
+The optional partial path for which this cookie will be valid, as described
+above.
+
+=item B<-domain>
+
+The optional partial domain for which this cookie will be valid, as described
+above.
+
+=item B<-expires>
+
+The optional expiration date for this cookie. The format is as described
+in the section on the B<header()> method:
+
+ "+1h" one hour from now
+
+=item B<-secure>
+
+If set to true, this cookie will only be used within a secure
+SSL session.
+
+=back
+
+The cookie created by cookie() must be incorporated into the HTTP
+header within the string returned by the header() method:
+
+ use CGI ':standard';
+ print header(-cookie=>$my_cookie);
+
+To create multiple cookies, give header() an array reference:
+
+ $cookie1 = cookie(-name=>'riddle_name',
+ -value=>"The Sphynx's Question");
+ $cookie2 = cookie(-name=>'answers',
+ -value=>\%answers);
+ print header(-cookie=>[$cookie1,$cookie2]);
+
+To retrieve a cookie, request it by name by calling cookie() method
+without the B<-value> parameter. This example uses the object-oriented
+form:
+
+ use CGI;
+ $query = CGI->new;
+ $riddle = $query->cookie('riddle_name');
+ %answers = $query->cookie('answers');
+
+Cookies created with a single scalar value, such as the "riddle_name"
+cookie, will be returned in that form. Cookies with array and hash
+values can also be retrieved.
+
+The cookie and CGI namespaces are separate. If you have a parameter
+named 'answers' and a cookie named 'answers', the values retrieved by
+param() and cookie() are independent of each other. However, it's
+simple to turn a CGI parameter into a cookie, and vice-versa:
+
+ # turn a CGI parameter into a cookie
+ $c=cookie(-name=>'answers',-value=>[param('answers')]);
+ # vice-versa
+ param(-name=>'answers',-value=>[cookie('answers')]);
+
+If you call cookie() without any parameters, it will return a list of
+the names of all cookies passed to your script:
+
+ @cookies = cookie();
+
+See the B<cookie.cgi> example script for some ideas on how to use
+cookies effectively.
+
+=head1 WORKING WITH FRAMES
+
+It's possible for CGI.pm scripts to write into several browser panels
+and windows using the HTML 4 frame mechanism. There are three
+techniques for defining new frames programmatically:
+
+=over 4
+
+=item 1. Create a <Frameset> document
+
+After writing out the HTTP header, instead of creating a standard
+HTML document using the start_html() call, create a <frameset>
+document that defines the frames on the page. Specify your script(s)
+(with appropriate parameters) as the SRC for each of the frames.
+
+There is no specific support for creating <frameset> sections
+in CGI.pm, but the HTML is very simple to write.
+
+=item 2. Specify the destination for the document in the HTTP header
+
+You may provide a B<-target> parameter to the header() method:
+
+ print header(-target=>'ResultsWindow');
+
+This will tell the browser to load the output of your script into the
+frame named "ResultsWindow". If a frame of that name doesn't already
+exist, the browser will pop up a new window and load your script's
+document into that. There are a number of magic names that you can
+use for targets. See the HTML C<< <frame> >> documentation for details.
+
+=item 3. Specify the destination for the document in the <form> tag
+
+You can specify the frame to load in the FORM tag itself. With
+CGI.pm it looks like this:
+
+ print start_form(-target=>'ResultsWindow');
+
+When your script is reinvoked by the form, its output will be loaded
+into the frame named "ResultsWindow". If one doesn't already exist
+a new window will be created.
+
+=back
+
+The script "frameset.cgi" in the examples directory shows one way to
+create pages in which the fill-out form and the response live in
+side-by-side frames.
+
+=head1 SUPPORT FOR JAVASCRIPT
+
+The usual way to use JavaScript is to define a set of functions in a
+<SCRIPT> block inside the HTML header and then to register event
+handlers in the various elements of the page. Events include such
+things as the mouse passing over a form element, a button being
+clicked, the contents of a text field changing, or a form being
+submitted. When an event occurs that involves an element that has
+registered an event handler, its associated JavaScript code gets
+called.
+
+The elements that can register event handlers include the <BODY> of an
+HTML document, hypertext links, all the various elements of a fill-out
+form, and the form itself. There are a large number of events, and
+each applies only to the elements for which it is relevant. Here is a
+partial list:
+
+=over 4
+
+=item B<onLoad>
+
+The browser is loading the current document. Valid in:
+
+ + The HTML <BODY> section only.
+
+=item B<onUnload>
+
+The browser is closing the current page or frame. Valid for:
+
+ + The HTML <BODY> section only.
+
+=item B<onSubmit>
+
+The user has pressed the submit button of a form. This event happens
+just before the form is submitted, and your function can return a
+value of false in order to abort the submission. Valid for:
+
+ + Forms only.
+
+=item B<onClick>
+
+The mouse has clicked on an item in a fill-out form. Valid for:
+
+ + Buttons (including submit, reset, and image buttons)
+ + Checkboxes
+ + Radio buttons
+
+=item B<onChange>
+
+The user has changed the contents of a field. Valid for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onFocus>
+
+The user has selected a field to work with. Valid for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onBlur>
+
+The user has deselected a field (gone to work somewhere else). Valid
+for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onSelect>
+
+The user has changed the part of a text field that is selected. Valid
+for:
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+
+=item B<onMouseOver>
+
+The mouse has moved over an element.
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=item B<onMouseOut>
+
+The mouse has moved off an element.
+
+ + Text fields
+ + Text areas
+ + Password fields
+ + File fields
+ + Popup Menus
+ + Scrolling lists
+
+=back
+
+In order to register a JavaScript event handler with an HTML element,
+just use the event name as a parameter when you call the corresponding
+CGI method. For example, to have your validateAge() JavaScript code
+executed every time the textfield named "age" changes, generate the
+field like this:
+
+ print textfield(-name=>'age',-onChange=>"validateAge(this)");
+
+This example assumes that you've already declared the validateAge()
+function by incorporating it into a <SCRIPT> block. The CGI.pm
+start_html() method provides a convenient way to create this section.
+
+Similarly, you can create a form that checks itself over for
+consistency and alerts the user if some essential value is missing by
+creating it this way:
+ print start_form(-onSubmit=>"validateMe(this)");
+
+See the javascript.cgi script for a demonstration of how this all
+works.
+
+
+=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
+
+CGI.pm has limited support for HTML3's cascading style sheets (css).
+To incorporate a stylesheet into your document, pass the
+start_html() method a B<-style> parameter. The value of this
+parameter may be a scalar, in which case it is treated as the source
+URL for the stylesheet, or it may be a hash reference. In the latter
+case you should provide the hash with one or more of B<-src> or
+B<-code>. B<-src> points to a URL where an externally-defined
+stylesheet can be found. B<-code> points to a scalar value to be
+incorporated into a <style> section. Style definitions in B<-code>
+override similarly-named ones in B<-src>, hence the name "cascading."
+
+You may also specify the type of the stylesheet by adding the optional
+B<-type> parameter to the hash pointed to by B<-style>. If not
+specified, the style defaults to 'text/css'.
+
+To refer to a style within the body of your document, add the
+B<-class> parameter to any HTML element:
+
+ print h1({-class=>'Fancy'},'Welcome to the Party');
+
+Or define styles on the fly with the B<-style> parameter:
+
+ print h1({-style=>'Color: red;'},'Welcome to Hell');
+
+You may also use the new B<span()> element to apply a style to a
+section of text:
+
+ print span({-style=>'Color: red;'},
+ h1('Welcome to Hell'),
+ "Where did that handbasket get to?"
+ );
+
+Note that you must import the ":html3" definitions to have the
+B<span()> method available. Here's a quick and dirty example of using
+CSS's. See the CSS specification at
+http://www.w3.org/Style/CSS/ for more information.
+
+ use CGI qw/:standard :html3/;
+
+ #here's a stylesheet incorporated directly into the page
+ $newStyle=<<END;
+ <!--
+ P.Tip {
+ margin-right: 50pt;
+ margin-left: 50pt;
+ color: red;
+ }
+ P.Alert {
+ font-size: 30pt;
+ font-family: sans-serif;
+ color: red;
+ }
+ -->
+ END
+ print header();
+ print start_html( -title=>'CGI with Style',
+ -style=>{-src=>'http://www.capricorn.com/style/st1.css',
+ -code=>$newStyle}
+ );
+ print h1('CGI with Style'),
+ p({-class=>'Tip'},
+ "Better read the cascading style sheet spec before playing with this!"),
+ span({-style=>'color: magenta'},
+ "Look Mom, no hands!",
+ p(),
+ "Whooo wee!"
+ );
+ print end_html;
+
+Pass an array reference to B<-code> or B<-src> in order to incorporate
+multiple stylesheets into your document.
+
+Should you wish to incorporate a verbatim stylesheet that includes
+arbitrary formatting in the header, you may pass a -verbatim tag to
+the -style hash, as follows:
+
+print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
+ -src => '/server-common/css/core.css'});
+
+
+This will generate an HTML header that contains this:
+
+ <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
+ <style type="text/css">
+ @import url("/server-common/css/main.css");
+ </style>
+
+Any additional arguments passed in the -style value will be
+incorporated into the <link> tag. For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+ -media => 'all'});
+
+This will give:
+
+ <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
+ <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
+
+<p>
+
+To make more complicated <link> tags, use the Link() function
+and pass it to start_html() in the -head argument, as in:
+
+ @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
+ Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
+ print start_html({-head=>\@h})
+
+To create primary and "alternate" stylesheet, use the B<-alternate> option:
+
+ start_html(-style=>{-src=>[
+ {-src=>'/styles/print.css'},
+ {-src=>'/styles/alt.css',-alternate=>1}
+ ]
+ });
+
+=head1 DEBUGGING
+
+If you are running the script from the command line or in the perl
+debugger, you can pass the script a list of keywords or
+parameter=value pairs on the command line or from standard input (you
+don't have to worry about tricking your script into reading from
+environment variables). You can pass keywords like this:
+
+ your_script.pl keyword1 keyword2 keyword3
+
+or this:
+
+ your_script.pl keyword1+keyword2+keyword3
+
+or this:
+
+ your_script.pl name1=value1 name2=value2
+
+or this:
+
+ your_script.pl name1=value1&name2=value2
+
+To turn off this feature, use the -no_debug pragma.
+
+To test the POST method, you may enable full debugging with the -debug
+pragma. This will allow you to feed newline-delimited name=value
+pairs to the script on standard input.
+
+When debugging, you can use quotes and backslashes to escape
+characters in the familiar shell manner, letting you place
+spaces and other funny characters in your parameter=value
+pairs:
+
+ your_script.pl "name1='I am a long value'" "name2=two\ words"
+
+Finally, you can set the path info for the script by prefixing the first
+name/value parameter with the path followed by a question mark (?):
+
+ your_script.pl /your/path/here?name1=value1&name2=value2
+
+=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
+
+The Dump() method produces a string consisting of all the query's
+name/value pairs formatted nicely as a nested list. This is useful
+for debugging purposes:
+
+ print Dump
+
+
+Produces something that looks like:
+
+ <ul>
+ <li>name1
+ <ul>
+ <li>value1
+ <li>value2
+ </ul>
+ <li>name2
+ <ul>
+ <li>value1
+ </ul>
+ </ul>
+
+As a shortcut, you can interpolate the entire CGI object into a string
+and it will be replaced with the a nice HTML dump shown above:
+
+ $query=CGI->new;
+ print "<h2>Current Values</h2> $query\n";
+
+=head1 FETCHING ENVIRONMENT VARIABLES
+
+Some of the more useful environment variables can be fetched
+through this interface. The methods are as follows:
+
+=over 4
+
+=item B<Accept()>
+
+Return a list of MIME types that the remote browser accepts. If you
+give this method a single argument corresponding to a MIME type, as in
+Accept('text/html'), it will return a floating point value
+corresponding to the browser's preference for this type from 0.0
+(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
+list are handled correctly.
+
+Note that the capitalization changed between version 2.43 and 2.44 in
+order to avoid conflict with Perl's accept() function.
+
+=item B<raw_cookie()>
+
+Returns the HTTP_COOKIE variable. Cookies have a special format, and
+this method call just returns the raw form (?cookie dough). See
+cookie() for ways of setting and retrieving cooked cookies.
+
+Called with no parameters, raw_cookie() returns the packed cookie
+structure. You can separate it into individual cookies by splitting
+on the character sequence "; ". Called with the name of a cookie,
+retrieves the B<unescaped> form of the cookie. You can use the
+regular cookie() method to get the names, or use the raw_fetch()
+method from the CGI::Cookie module.
+
+=item B<user_agent()>
+
+Returns the HTTP_USER_AGENT variable. If you give
+this method a single argument, it will attempt to
+pattern match on it, allowing you to do something
+like user_agent(Mozilla);
+
+=item B<path_info()>
+
+Returns additional path information from the script URL.
+E.G. fetching /cgi-bin/your_script/additional/stuff will result in
+path_info() returning "/additional/stuff".
+
+NOTE: The Microsoft Internet Information Server
+is broken with respect to additional path information. If
+you use the Perl DLL library, the IIS server will attempt to
+execute the additional path information as a Perl script.
+If you use the ordinary file associations mapping, the
+path information will be present in the environment,
+but incorrect. The best thing to do is to avoid using additional
+path information in CGI scripts destined for use with IIS.
+
+=item B<path_translated()>
+
+As per path_info() but returns the additional
+path information translated into a physical path, e.g.
+"/usr/local/etc/httpd/htdocs/additional/stuff".
+
+The Microsoft IIS is broken with respect to the translated
+path as well.
+
+=item B<remote_host()>
+
+Returns either the remote host name or IP address.
+if the former is unavailable.
+
+=item B<remote_addr()>
+
+Returns the remote host IP address, or
+127.0.0.1 if the address is unavailable.
+
+=item B<script_name()>
+Return the script name as a partial URL, for self-refering
+scripts.
+
+=item B<referer()>
+
+Return the URL of the page the browser was viewing
+prior to fetching your script. Not available for all
+browsers.
+
+=item B<auth_type ()>
+
+Return the authorization/verification method in use for this
+script, if any.
+
+=item B<server_name ()>
+
+Returns the name of the server, usually the machine's host
+name.
+
+=item B<virtual_host ()>
+
+When using virtual hosts, returns the name of the host that
+the browser attempted to contact
+
+=item B<server_port ()>
+
+Return the port that the server is listening on.
+
+=item B<virtual_port ()>
+
+Like server_port() except that it takes virtual hosts into account.
+Use this when running with virtual hosts.
+
+=item B<server_software ()>
+
+Returns the server software and version number.
+
+=item B<remote_user ()>
+
+Return the authorization/verification name used for user
+verification, if this script is protected.
+
+=item B<user_name ()>
+
+Attempt to obtain the remote user's name, using a variety of different
+techniques. This only works with older browsers such as Mosaic.
+Newer browsers do not report the user name for privacy reasons!
+
+=item B<request_method()>
+
+Returns the method used to access your script, usually
+one of 'POST', 'GET' or 'HEAD'.
+
+=item B<content_type()>
+
+Returns the content_type of data submitted in a POST, generally
+multipart/form-data or application/x-www-form-urlencoded
+
+=item B<http()>
+
+Called with no arguments returns the list of HTTP environment
+variables, including such things as HTTP_USER_AGENT,
+HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
+like-named HTTP header fields in the request. Called with the name of
+an HTTP header field, returns its value. Capitalization and the use
+of hyphens versus underscores are not significant.
+
+For example, all three of these examples are equivalent:
+
+ $requested_language = http('Accept-language');
+ $requested_language = http('Accept_language');
+ $requested_language = http('HTTP_ACCEPT_LANGUAGE');
+
+=item B<https()>
+
+The same as I<http()>, but operates on the HTTPS environment variables
+present when the SSL protocol is in effect. Can be used to determine
+whether SSL is turned on.
+
+=back
+
+=head1 USING NPH SCRIPTS
+
+NPH, or "no-parsed-header", scripts bypass the server completely by
+sending the complete HTTP header directly to the browser. This has
+slight performance benefits, but is of most use for taking advantage
+of HTTP extensions that are not directly supported by your server,
+such as server push and PICS headers.
+
+Servers use a variety of conventions for designating CGI scripts as
+NPH. Many Unix servers look at the beginning of the script's name for
+the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
+Internet Information Server, in contrast, try to decide whether a
+program is an NPH script by examining the first line of script output.
+
+
+CGI.pm supports NPH scripts with a special NPH mode. When in this
+mode, CGI.pm will output the necessary extra header information when
+the header() and redirect() methods are
+called.
+
+The Microsoft Internet Information Server requires NPH mode. As of
+version 2.30, CGI.pm will automatically detect when the script is
+running under IIS and put itself into this mode. You do not need to
+do this manually, although it won't hurt anything if you do. However,
+note that if you have applied Service Pack 6, much of the
+functionality of NPH scripts, including the ability to redirect while
+setting a cookie, B<do not work at all> on IIS without a special patch
+from Microsoft. See
+http://web.archive.org/web/20010812012030/http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
+Non-Parsed Headers Stripped From CGI Applications That Have nph-
+Prefix in Name.
+
+=over 4
+
+=item In the B<use> statement
+
+Simply add the "-nph" pragmato the list of symbols to be imported into
+your script:
+
+ use CGI qw(:standard -nph)
+
+=item By calling the B<nph()> method:
+
+Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
+
+ CGI->nph(1)
+
+=item By using B<-nph> parameters
+
+in the B<header()> and B<redirect()> statements:
+
+ print header(-nph=>1);
+
+=back
+
+=head1 Server Push
+
+CGI.pm provides four simple functions for producing multipart
+documents of the type needed to implement server push. These
+functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
+import these into your namespace, you must import the ":push" set.
+You are also advised to put the script into NPH mode and to set $| to
+1 to avoid buffering problems.
+
+Here is a simple script that demonstrates server push:
+
+ #!/usr/local/bin/perl
+ use CGI qw/:push -nph/;
+ $| = 1;
+ print multipart_init(-boundary=>'----here we go!');
+ for (0 .. 4) {
+ print multipart_start(-type=>'text/plain'),
+ "The current time is ",scalar(localtime),"\n";
+ if ($_ < 4) {
+ print multipart_end;
+ } else {
+ print multipart_final;
+ }
+ sleep 1;
+ }
+
+This script initializes server push by calling B<multipart_init()>.
+It then enters a loop in which it begins a new multipart section by
+calling B<multipart_start()>, prints the current local time,
+and ends a multipart section with B<multipart_end()>. It then sleeps
+a second, and begins again. On the final iteration, it ends the
+multipart section with B<multipart_final()> rather than with
+B<multipart_end()>.
+
+=over 4
+
+=item multipart_init()
+
+ multipart_init(-boundary=>$boundary);
+
+Initialize the multipart system. The -boundary argument specifies
+what MIME boundary string to use to separate parts of the document.
+If not provided, CGI.pm chooses a reasonable boundary for you.
+
+=item multipart_start()
+
+ multipart_start(-type=>$type)
+
+Start a new part of the multipart document using the specified MIME
+type. If not specified, text/html is assumed.
+
+=item multipart_end()
+
+ multipart_end()
+
+End a part. You must remember to call multipart_end() once for each
+multipart_start(), except at the end of the last part of the multipart
+document when multipart_final() should be called instead of multipart_end().
+
+=item multipart_final()
+
+ multipart_final()
+
+End all parts. You should call multipart_final() rather than
+multipart_end() at the end of the last part of the multipart document.
+
+=back
+
+Users interested in server push applications should also have a look
+at the CGI::Push module.
+
+=head1 Avoiding Denial of Service Attacks
+
+A potential problem with CGI.pm is that, by default, it attempts to
+process form POSTings no matter how large they are. A wily hacker
+could attack your site by sending a CGI script a huge POST of many
+megabytes. CGI.pm will attempt to read the entire POST into a
+variable, growing hugely in size until it runs out of memory. While
+the script attempts to allocate the memory the system may slow down
+dramatically. This is a form of denial of service attack.
+
+Another possible attack is for the remote user to force CGI.pm to
+accept a huge file upload. CGI.pm will accept the upload and store it
+in a temporary directory even if your script doesn't expect to receive
+an uploaded file. CGI.pm will delete the file automatically when it
+terminates, but in the meantime the remote user may have filled up the
+server's disk space, causing problems for other programs.
+
+The best way to avoid denial of service attacks is to limit the amount
+of memory, CPU time and disk space that CGI scripts can use. Some Web
+servers come with built-in facilities to accomplish this. In other
+cases, you can use the shell I<limit> or I<ulimit>
+commands to put ceilings on CGI resource usage.
+
+
+CGI.pm also has some simple built-in protections against denial of
+service attacks, but you must activate them before you can use them.
+These take the form of two global variables in the CGI name space:
+
+=over 4
+
+=item B<$CGI::POST_MAX>
+
+If set to a non-negative integer, this variable puts a ceiling
+on the size of POSTings, in bytes. If CGI.pm detects a POST
+that is greater than the ceiling, it will immediately exit with an error
+message. This value will affect both ordinary POSTs and
+multipart POSTs, meaning that it limits the maximum size of file
+uploads as well. You should set this to a reasonably high
+value, such as 1 megabyte.
+
+=item B<$CGI::DISABLE_UPLOADS>
+
+If set to a non-zero value, this will disable file uploads
+completely. Other fill-out form values will work as usual.
+
+=back
+
+You can use these variables in either of two ways.
+
+=over 4
+
+=item B<1. On a script-by-script basis>
+
+Set the variable at the top of the script, right after the "use" statement:
+
+ use CGI qw/:standard/;
+ use CGI::Carp 'fatalsToBrowser';
+ $CGI::POST_MAX=1024 * 100; # max 100K posts
+ $CGI::DISABLE_UPLOADS = 1; # no uploads
+
+=item B<2. Globally for all scripts>
+
+Open up CGI.pm, find the definitions for $POST_MAX and
+$DISABLE_UPLOADS, and set them to the desired values. You'll
+find them towards the top of the file in a subroutine named
+initialize_globals().
+
+=back
+
+An attempt to send a POST larger than $POST_MAX bytes will cause
+I<param()> to return an empty CGI parameter list. You can test for
+this event by checking I<cgi_error()>, either after you create the CGI
+object or, if you are using the function-oriented interface, call
+<param()> for the first time. If the POST was intercepted, then
+cgi_error() will return the message "413 POST too large".
+
+This error message is actually defined by the HTTP protocol, and is
+designed to be returned to the browser as the CGI script's status
+ code. For example:
+
+ $uploaded_file = param('upload');
+ if (!$uploaded_file && cgi_error()) {
+ print header(-status=>cgi_error());
+ exit 0;
+ }
+
+However it isn't clear that any browser currently knows what to do
+with this status code. It might be better just to create an
+HTML page that warns the user of the problem.
+
+=head1 COMPATIBILITY WITH CGI-LIB.PL
+
+To make it easier to port existing programs that use cgi-lib.pl the
+compatibility routine "ReadParse" is provided. Porting is simple:
+
+OLD VERSION
+ require "cgi-lib.pl";
+ &ReadParse;
+ print "The value of the antique is $in{antique}.\n";
+
+NEW VERSION
+ use CGI;
+ CGI::ReadParse();
+ print "The value of the antique is $in{antique}.\n";
+
+CGI.pm's ReadParse() routine creates a tied variable named %in,
+which can be accessed to obtain the query variables. Like
+ReadParse, you can also provide your own variable. Infrequently
+used features of ReadParse, such as the creation of @in and $in
+variables, are not supported.
+
+Once you use ReadParse, you can retrieve the query object itself
+this way:
+
+ $q = $in{CGI};
+ print textfield(-name=>'wow',
+ -value=>'does this really work?');
+
+This allows you to start using the more interesting features
+of CGI.pm without rewriting your old scripts from scratch.
+
+=head1 AUTHOR INFORMATION
+
+The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
+distributed under GPL and the Artistic License 2.0.
+
+Address bug reports and comments to: lstein@cshl.org. When sending
+bug reports, please provide the version of CGI.pm, the version of
+Perl, the name and version of your Web server, and the name and
+version of the operating system you are using. If the problem is even
+remotely browser dependent, please provide information about the
+affected browers as well.
+
+=head1 CREDITS
+
+Thanks very much to:
+
+=over 4
+
+=item Matt Heffron (heffron@falstaff.css.beckman.com)
+
+=item James Taylor (james.taylor@srs.gov)
+
+=item Scott Anguish <sanguish@digifix.com>
+
+=item Mike Jewell (mlj3u@virginia.edu)
+
+=item Timothy Shimmin (tes@kbs.citri.edu.au)
+
+=item Joergen Haegg (jh@axis.se)
+
+=item Laurent Delfosse (delfosse@delfosse.com)
+
+=item Richard Resnick (applepi1@aol.com)
+
+=item Craig Bishop (csb@barwonwater.vic.gov.au)
+
+=item Tony Curtis (tc@vcpc.univie.ac.at)
+
+=item Tim Bunce (Tim.Bunce@ig.co.uk)
+
+=item Tom Christiansen (tchrist@convex.com)
+
+=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
+
+=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
+
+=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
+
+=item Stephen Dahmen (joyfire@inxpress.net)
+
+=item Ed Jordan (ed@fidalgo.net)
+
+=item David Alan Pisoni (david@cnation.com)
+
+=item Doug MacEachern (dougm@opengroup.org)
+
+=item Robin Houston (robin@oneworld.org)
+
+=item ...and many many more...
+
+for suggestions and bug fixes.
+
+=back
+
+=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
+
+
+ #!/usr/local/bin/perl
+
+ use CGI ':standard';
+
+ print header;
+ print start_html("Example CGI.pm Form");
+ print "<h1> Example CGI.pm Form</h1>\n";
+ print_prompt();
+ do_work();
+ print_tail();
+ print end_html;
+
+ sub print_prompt {
+ print start_form;
+ print "<em>What's your name?</em><br>";
+ print textfield('name');
+ print checkbox('Not my real name');
+
+ print "<p><em>Where can you find English Sparrows?</em><br>";
+ print checkbox_group(
+ -name=>'Sparrow locations',
+ -values=>[England,France,Spain,Asia,Hoboken],
+ -linebreak=>'yes',
+ -defaults=>[England,Asia]);
+
+ print "<p><em>How far can they fly?</em><br>",
+ radio_group(
+ -name=>'how far',
+ -values=>['10 ft','1 mile','10 miles','real far'],
+ -default=>'1 mile');
+
+ print "<p><em>What's your favorite color?</em> ";
+ print popup_menu(-name=>'Color',
+ -values=>['black','brown','red','yellow'],
+ -default=>'red');
+
+ print hidden('Reference','Monty Python and the Holy Grail');
+
+ print "<p><em>What have you got there?</em><br>";
+ print scrolling_list(
+ -name=>'possessions',
+ -values=>['A Coconut','A Grail','An Icon',
+ 'A Sword','A Ticket'],
+ -size=>5,
+ -multiple=>'true');
+
+ print "<p><em>Any parting comments?</em><br>";
+ print textarea(-name=>'Comments',
+ -rows=>10,
+ -columns=>50);
+
+ print "<p>",reset;
+ print submit('Action','Shout');
+ print submit('Action','Scream');
+ print end_form;
+ print "<hr>\n";
+ }
+
+ sub do_work {
+
+ print "<h2>Here are the current settings in this form</h2>";
+
+ for my $key (param) {
+ print "<strong>$key</strong> -> ";
+ my @values = param($key);
+ print join(", ",@values),"<br>\n";
+ }
+ }
+
+ sub print_tail {
+ print <<END;
+ <hr>
+ <address>Lincoln D. Stein</address><br>
+ <a href="/">Home Page</a>
+ END
+ }
+
+=head1 BUGS
+
+Please report them.
+
+=head1 SEE ALSO
+
+L<CGI::Carp> - provides a L<Carp> implementation tailored to the CGI environment.
+
+L<CGI::Fast> - supports running CGI applications under FastCGI
+
+L<CGI::Pretty> - pretty prints HTML generated by CGI.pm (with a performance penalty)
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/CORE.pod b/Master/tlpkg/tlperl/lib/CORE.pod
new file mode 100644
index 00000000000..c917bba44a0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CORE.pod
@@ -0,0 +1,62 @@
+=head1 NAME
+
+CORE - Pseudo-namespace for Perl's core routines
+
+=head1 SYNOPSIS
+
+ BEGIN {
+ *CORE::GLOBAL::hex = sub { 1; };
+ }
+
+ print hex("0x50"),"\n"; # prints 1
+ print CORE::hex("0x50"),"\n"; # prints 80
+
+=head1 DESCRIPTION
+
+The C<CORE> namespace gives access to the original built-in functions of
+Perl. There is no C<CORE> package, and therefore you do not need to use or
+require an hypothetical "CORE" module prior to accessing routines in this
+namespace.
+
+A list of the built-in functions in Perl can be found in L<perlfunc>.
+
+=head1 OVERRIDING CORE FUNCTIONS
+
+To override a Perl built-in routine with your own version, you need to
+import it at compile-time. This can be conveniently achieved with the
+C<subs> pragma. This will affect only the package in which you've imported
+the said subroutine:
+
+ use subs 'chdir';
+ sub chdir { ... }
+ chdir $somewhere;
+
+To override a built-in globally (that is, in all namespaces), you need to
+import your function into the C<CORE::GLOBAL> pseudo-namespace at compile
+time:
+
+ BEGIN {
+ *CORE::GLOBAL::hex = sub {
+ # ... your code here
+ };
+ }
+
+The new routine will be called whenever a built-in function is called
+without a qualifying package:
+
+ print hex("0x50"),"\n"; # prints 1
+
+In both cases, if you want access to the original, unaltered routine, use
+the C<CORE::> prefix:
+
+ print CORE::hex("0x50"),"\n"; # prints 80
+
+=head1 AUTHOR
+
+This documentation provided by Tels <nospam-abuse@bloodgate.com> 2007.
+
+=head1 SEE ALSO
+
+L<perlsub>, L<perlfunc>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN.pm b/Master/tlpkg/tlperl/lib/CPAN.pm
new file mode 100644
index 00000000000..9d09708afcc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPAN.pm
@@ -0,0 +1,3774 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+use strict;
+package CPAN;
+$CPAN::VERSION = '1.94_56';
+$CPAN::VERSION =~ s/_//;
+
+# we need to run chdir all over and we would get at wrong libraries
+# there
+use File::Spec ();
+BEGIN {
+ if (File::Spec->can("rel2abs")) {
+ for my $inc (@INC) {
+ $inc = File::Spec->rel2abs($inc) unless ref $inc;
+ }
+ }
+}
+use CPAN::Author;
+use CPAN::HandleConfig;
+use CPAN::Version;
+use CPAN::Bundle;
+use CPAN::CacheMgr;
+use CPAN::Complete;
+use CPAN::Debug;
+use CPAN::Distribution;
+use CPAN::Distrostatus;
+use CPAN::FTP;
+use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
+use CPAN::InfoObj;
+use CPAN::Module;
+use CPAN::Prompt;
+use CPAN::URL;
+use CPAN::Queue;
+use CPAN::Tarzip;
+use CPAN::DeferredCode;
+use CPAN::Shell;
+use CPAN::LWP::UserAgent;
+use CPAN::Exception::RecursiveDependency;
+use CPAN::Exception::yaml_not_installed;
+
+use Carp ();
+use Config ();
+use Cwd qw(chdir);
+use DirHandle ();
+use Exporter ();
+use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
+ # 5.005_04 does not work without
+ # this
+use File::Basename ();
+use File::Copy ();
+use File::Find;
+use File::Path ();
+use FileHandle ();
+use Fcntl qw(:flock);
+use Safe ();
+use Sys::Hostname qw(hostname);
+use Text::ParseWords ();
+use Text::Wrap ();
+
+# protect against "called too early"
+sub find_perl ();
+sub anycwd ();
+sub _uniq;
+
+no lib ".";
+
+require Mac::BuildTools if $^O eq 'MacOS';
+if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
+ $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
+ my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$;
+ $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec;
+ # warn "# Note: Recursive call of CPAN.pm detected\n";
+ my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
+ my %sleep = (
+ 5 => 30,
+ 6 => 60,
+ 7 => 120,
+ );
+ my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
+ my $verbose = @rec >= 4;
+ while (@rec) {
+ $w .= sprintf " which has been called by process %d", pop @rec;
+ }
+ if ($sleep) {
+ $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
+ }
+ if ($verbose) {
+ warn $w;
+ }
+ local $| = 1;
+ while ($sleep > 0) {
+ printf "\r#%5d", --$sleep;
+ sleep 1;
+ }
+ print "\n";
+}
+$ENV{PERL5_CPAN_IS_RUNNING}=$$;
+$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
+
+END { $CPAN::End++; &cleanup; }
+
+$CPAN::Signal ||= 0;
+$CPAN::Frontend ||= "CPAN::Shell";
+unless (@CPAN::Defaultsites) {
+ @CPAN::Defaultsites = map {
+ CPAN::URL->new(TEXT => $_, FROM => "DEF")
+ }
+ "http://www.perl.org/CPAN/",
+ "ftp://ftp.perl.org/pub/CPAN/";
+}
+# $CPAN::iCwd (i for initial)
+$CPAN::iCwd ||= CPAN::anycwd();
+$CPAN::Perl ||= CPAN::find_perl();
+$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
+$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
+$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
+
+# our globals are getting a mess
+use vars qw(
+ $AUTOLOAD
+ $Be_Silent
+ $CONFIG_DIRTY
+ $Defaultdocs
+ $Echo_readline
+ $Frontend
+ $GOTOSHELL
+ $HAS_USABLE
+ $Have_warned
+ $MAX_RECURSION
+ $META
+ $RUN_DEGRADED
+ $Signal
+ $SQLite
+ $Suppress_readline
+ $VERSION
+ $autoload_recursion
+ $term
+ @Defaultsites
+ @EXPORT
+ );
+
+$MAX_RECURSION = 32;
+
+@CPAN::ISA = qw(CPAN::Debug Exporter);
+
+# note that these functions live in CPAN::Shell and get executed via
+# AUTOLOAD when called directly
+@EXPORT = qw(
+ autobundle
+ bundle
+ clean
+ cvs_import
+ expand
+ force
+ fforce
+ get
+ install
+ install_tested
+ is_tested
+ make
+ mkmyconfig
+ notest
+ perldoc
+ readme
+ recent
+ recompile
+ report
+ shell
+ smoke
+ test
+ upgrade
+ );
+
+sub soft_chdir_with_alternatives ($);
+
+{
+ $autoload_recursion ||= 0;
+
+ #-> sub CPAN::AUTOLOAD ;
+ sub AUTOLOAD { ## no critic
+ $autoload_recursion++;
+ my($l) = $AUTOLOAD;
+ $l =~ s/.*:://;
+ if ($CPAN::Signal) {
+ warn "Refusing to autoload '$l' while signal pending";
+ $autoload_recursion--;
+ return;
+ }
+ if ($autoload_recursion > 1) {
+ my $fullcommand = join " ", map { "'$_'" } $l, @_;
+ warn "Refusing to autoload $fullcommand in recursion\n";
+ $autoload_recursion--;
+ return;
+ }
+ my(%export);
+ @export{@EXPORT} = '';
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ if (exists $export{$l}) {
+ CPAN::Shell->$l(@_);
+ } else {
+ die(qq{Unknown CPAN command "$AUTOLOAD". }.
+ qq{Type ? for help.\n});
+ }
+ $autoload_recursion--;
+ }
+}
+
+{
+ my $x = *SAVEOUT; # avoid warning
+ open($x,">&STDOUT") or die "dup failed";
+ my $redir = 0;
+ sub _redirect(@) {
+ #die if $redir;
+ local $_;
+ push(@_,undef);
+ while(defined($_=shift)) {
+ if (s/^\s*>//){
+ my ($m) = s/^>// ? ">" : "";
+ s/\s+//;
+ $_=shift unless length;
+ die "no dest" unless defined;
+ open(STDOUT,">$m$_") or die "open:$_:$!\n";
+ $redir=1;
+ } elsif ( s/^\s*\|\s*// ) {
+ my $pipe="| $_";
+ while(defined($_[0])){
+ $pipe .= ' ' . shift;
+ }
+ open(STDOUT,$pipe) or die "open:$pipe:$!\n";
+ $redir=1;
+ } else {
+ push(@_,$_);
+ }
+ }
+ return @_;
+ }
+ sub _unredirect {
+ return unless $redir;
+ $redir = 0;
+ ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
+ close(STDOUT);
+ open(STDOUT,">&SAVEOUT");
+ die "$@" if "$@";
+ ## redirect: done
+ }
+}
+
+sub _uniq {
+ my(@list) = @_;
+ my %seen;
+ return grep { !$seen{$_}++ } @list;
+}
+
+#-> sub CPAN::shell ;
+sub shell {
+ my($self) = @_;
+ $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+
+ my $oprompt = shift || CPAN::Prompt->new;
+ my $prompt = $oprompt;
+ my $commandline = shift || "";
+ $CPAN::CurrentCommandId ||= 1;
+
+ local($^W) = 1;
+ unless ($Suppress_readline) {
+ require Term::ReadLine;
+ if (! $term
+ or
+ $term->ReadLine eq "Term::ReadLine::Stub"
+ ) {
+ $term = Term::ReadLine->new('CPAN Monitor');
+ }
+ if ($term->ReadLine eq "Term::ReadLine::Gnu") {
+ my $attribs = $term->Attribs;
+ $attribs->{attempted_completion_function} = sub {
+ &CPAN::Complete::gnu_cpl;
+ }
+ } else {
+ $readline::rl_completion_function =
+ $readline::rl_completion_function = 'CPAN::Complete::cpl';
+ }
+ if (my $histfile = $CPAN::Config->{'histfile'}) {{
+ unless ($term->can("AddHistory")) {
+ $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
+ last;
+ }
+ $META->readhist($term,$histfile);
+ }}
+ for ($CPAN::Config->{term_ornaments}) { # alias
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $term->ornaments($_) if defined;
+ }
+ # $term->OUT is autoflushed anyway
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 1;
+ select $odef;
+ }
+
+ $META->checklock();
+ my @cwd = grep { defined $_ and length $_ }
+ CPAN::anycwd(),
+ File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
+ File::Spec->rootdir();
+ my $try_detect_readline;
+ $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
+ unless ($CPAN::Config->{inhibit_startup_message}) {
+ my $rl_avail = $Suppress_readline ? "suppressed" :
+ ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
+ "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
+ $CPAN::Frontend->myprint(
+ sprintf qq{
+cpan shell -- CPAN exploration and modules installation (v%s)
+Enter 'h' for help.
+
+},
+ $CPAN::VERSION,
+ $rl_avail
+ )
+ }
+ my($continuation) = "";
+ my $last_term_ornaments;
+ SHELLCOMMAND: while () {
+ if ($Suppress_readline) {
+ if ($Echo_readline) {
+ $|=1;
+ }
+ print $prompt;
+ last SHELLCOMMAND unless defined ($_ = <> );
+ if ($Echo_readline) {
+ # backdoor: I could not find a way to record sessions
+ print $_;
+ }
+ chomp;
+ } else {
+ last SHELLCOMMAND unless
+ defined ($_ = $term->readline($prompt, $commandline));
+ }
+ $_ = "$continuation$_" if $continuation;
+ s/^\s+//;
+ next SHELLCOMMAND if /^$/;
+ s/^\s*\?\s*/help /;
+ if (/^(?:q(?:uit)?|bye|exit)\s*$/i) {
+ last SHELLCOMMAND;
+ } elsif (s/\\$//s) {
+ chomp;
+ $continuation = $_;
+ $prompt = " > ";
+ } elsif (/^\!/) {
+ s/^\!//;
+ my($eval) = $_;
+ package
+ CPAN::Eval; # hide from the indexer
+ use strict;
+ use vars qw($import_done);
+ CPAN->import(':DEFAULT') unless $import_done++;
+ CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
+ eval($eval);
+ warn $@ if $@;
+ $continuation = "";
+ $prompt = $oprompt;
+ } elsif (/./) {
+ my(@line);
+ eval { @line = Text::ParseWords::shellwords($_) };
+ warn($@), next SHELLCOMMAND if $@;
+ warn("Text::Parsewords could not parse the line [$_]"),
+ next SHELLCOMMAND unless @line;
+ $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
+ my $command = shift @line;
+ eval {
+ local (*STDOUT)=*STDOUT;
+ @line = _redirect(@line);
+ CPAN::Shell->$command(@line)
+ };
+ my $command_error = $@;
+ _unredirect;
+ my $reported_error;
+ if ($command_error) {
+ my $err = $command_error;
+ if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) {
+ $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err");
+ $reported_error = ref $err;
+ } else {
+ # I'd prefer never to arrive here and make all errors exception objects
+ if ($err =~ /\S/) {
+ require Carp;
+ require Dumpvalue;
+ my $dv = Dumpvalue->new(tick => '"');
+ Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
+ }
+ }
+ }
+ if ($command =~ /^(
+ # classic commands
+ make
+ |test
+ |install
+ |clean
+
+ # pragmas for classic commands
+ |ff?orce
+ |notest
+
+ # compounds
+ |report
+ |smoke
+ |upgrade
+ )$/x) {
+ # only commands that tell us something about failed distros
+ # eval necessary for people without an urllist
+ eval {CPAN::Shell->failed($CPAN::CurrentCommandId,1);};
+ if (my $err = $@) {
+ unless (ref $err and $reported_error eq ref $err) {
+ die $@;
+ }
+ }
+ }
+ soft_chdir_with_alternatives(\@cwd);
+ $CPAN::Frontend->myprint("\n");
+ $continuation = "";
+ $CPAN::CurrentCommandId++;
+ $prompt = $oprompt;
+ }
+ } continue {
+ $commandline = ""; # I do want to be able to pass a default to
+ # shell, but on the second command I see no
+ # use in that
+ $Signal=0;
+ CPAN::Queue->nullify_queue;
+ if ($try_detect_readline) {
+ if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
+ ||
+ $CPAN::META->has_inst("Term::ReadLine::Perl")
+ ) {
+ delete $INC{"Term/ReadLine.pm"};
+ my $redef = 0;
+ local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
+ require Term::ReadLine;
+ $CPAN::Frontend->myprint("\n$redef subroutines in ".
+ "Term::ReadLine redefined\n");
+ $GOTOSHELL = 1;
+ }
+ }
+ if ($term and $term->can("ornaments")) {
+ for ($CPAN::Config->{term_ornaments}) { # alias
+ if (defined $_) {
+ if (not defined $last_term_ornaments
+ or $_ != $last_term_ornaments
+ ) {
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $term->ornaments($_);
+ $last_term_ornaments = $_;
+ }
+ } else {
+ undef $last_term_ornaments;
+ }
+ }
+ }
+ for my $class (qw(Module Distribution)) {
+ # again unsafe meta access?
+ for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
+ next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
+ CPAN->debug("BUG: $class '$dm' was in command state, resetting");
+ delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
+ }
+ }
+ if ($GOTOSHELL) {
+ $GOTOSHELL = 0; # not too often
+ $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
+ @_ = ($oprompt,"");
+ goto &shell;
+ }
+ }
+ soft_chdir_with_alternatives(\@cwd);
+}
+
+#-> CPAN::soft_chdir_with_alternatives ;
+sub soft_chdir_with_alternatives ($) {
+ my($cwd) = @_;
+ unless (@$cwd) {
+ my $root = File::Spec->rootdir();
+ $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
+Trying '$root' as temporary haven.
+});
+ push @$cwd, $root;
+ }
+ while () {
+ if (chdir $cwd->[0]) {
+ return;
+ } else {
+ if (@$cwd>1) {
+ $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
+Trying to chdir to "$cwd->[1]" instead.
+});
+ shift @$cwd;
+ } else {
+ $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
+ }
+ }
+ }
+}
+
+sub _flock {
+ my($fh,$mode) = @_;
+ if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
+ return flock $fh, $mode;
+ } elsif (!$Have_warned->{"d_flock"}++) {
+ $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n");
+ $CPAN::Frontend->mysleep(5);
+ return 1;
+ } else {
+ return 1;
+ }
+}
+
+sub _yaml_module () {
+ my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
+ if (
+ $yaml_module ne "YAML"
+ &&
+ !$CPAN::META->has_inst($yaml_module)
+ ) {
+ # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
+ $yaml_module = "YAML";
+ }
+ if ($yaml_module eq "YAML"
+ &&
+ $CPAN::META->has_inst($yaml_module)
+ &&
+ $YAML::VERSION < 0.60
+ &&
+ !$Have_warned->{"YAML"}++
+ ) {
+ $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
+ "I'll continue but problems are *very* likely to happen.\n"
+ );
+ $CPAN::Frontend->mysleep(5);
+ }
+ return $yaml_module;
+}
+
+# CPAN::_yaml_loadfile
+sub _yaml_loadfile {
+ my($self,$local_file) = @_;
+ return +[] unless -s $local_file;
+ my $yaml_module = _yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ # temporarly enable yaml code deserialisation
+ no strict 'refs';
+ # 5.6.2 could not do the local() with the reference
+ # so we do it manually instead
+ my $old_loadcode = ${"$yaml_module\::LoadCode"};
+ ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
+
+ my ($code, @yaml);
+ if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
+ eval { @yaml = $code->($local_file); };
+ if ($@) {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
+ }
+ } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
+ local *FH;
+ open FH, $local_file or die "Could not open '$local_file': $!";
+ local $/;
+ my $ystream = <FH>;
+ eval { @yaml = $code->($ystream); };
+ if ($@) {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
+ }
+ }
+ ${"$yaml_module\::LoadCode"} = $old_loadcode;
+ return \@yaml;
+ } else {
+ # this shall not be done by the frontend
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
+ }
+ return +[];
+}
+
+# CPAN::_yaml_dumpfile
+sub _yaml_dumpfile {
+ my($self,$local_file,@what) = @_;
+ my $yaml_module = _yaml_module;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my $code;
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
+ $code = UNIVERSAL::can($yaml_module, "Dump");
+ eval { print $local_file $code->(@what) };
+ } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
+ eval { $code->($local_file,@what); };
+ } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
+ local *FH;
+ open FH, ">$local_file" or die "Could not open '$local_file': $!";
+ print FH $code->(@what);
+ }
+ if ($@) {
+ die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
+ }
+ } else {
+ if (UNIVERSAL::isa($local_file, "FileHandle")) {
+ # I think this case does not justify a warning at all
+ } else {
+ die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
+ }
+ }
+}
+
+sub _init_sqlite () {
+ unless ($CPAN::META->has_inst("CPAN::SQLite")) {
+ $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
+ unless $Have_warned->{"CPAN::SQLite"}++;
+ return;
+ }
+ require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
+ $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
+}
+
+{
+ my $negative_cache = {};
+ sub _sqlite_running {
+ if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
+ # need to cache the result, otherwise too slow
+ return $negative_cache->{fact};
+ } else {
+ $negative_cache = {}; # reset
+ }
+ my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
+ return $ret if $ret; # fast anyway
+ $negative_cache->{time} = time;
+ return $negative_cache->{fact} = $ret;
+ }
+}
+
+$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
+
+# from here on only subs.
+################################################################################
+
+sub _perl_fingerprint {
+ my($self,$other_fingerprint) = @_;
+ my $dll = eval {OS2::DLLname()};
+ my $mtime_dll = 0;
+ if (defined $dll) {
+ $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
+ }
+ my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
+ my $this_fingerprint = {
+ '$^X' => CPAN::find_perl,
+ sitearchexp => $Config::Config{sitearchexp},
+ 'mtime_$^X' => $mtime_perl,
+ 'mtime_dll' => $mtime_dll,
+ };
+ if ($other_fingerprint) {
+ if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
+ $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
+ }
+ # mandatory keys since 1.88_57
+ for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
+ return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
+ }
+ return 1;
+ } else {
+ return $this_fingerprint;
+ }
+}
+
+sub suggest_myconfig () {
+ SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
+ $CPAN::Frontend->myprint("You don't seem to have a user ".
+ "configuration (MyConfig.pm) yet.\n");
+ my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
+ "user configuration now? (Y/n)",
+ "yes");
+ if($new =~ m{^y}i) {
+ CPAN::Shell->mkmyconfig();
+ return &checklock;
+ } else {
+ $CPAN::Frontend->mydie("OK, giving up.");
+ }
+ }
+}
+
+#-> sub CPAN::all_objects ;
+sub all_objects {
+ my($mgr,$class) = @_;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
+ CPAN::Index->reload;
+ values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
+}
+
+# Called by shell, not in batch mode. In batch mode I see no risk in
+# having many processes updating something as installations are
+# continually checked at runtime. In shell mode I suspect it is
+# unintentional to open more than one shell at a time
+
+#-> sub CPAN::checklock ;
+sub checklock {
+ my($self) = @_;
+ my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
+ if (-f $lockfile && -M _ > 0) {
+ my $fh = FileHandle->new($lockfile) or
+ $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
+ my $otherpid = <$fh>;
+ my $otherhost = <$fh>;
+ $fh->close;
+ if (defined $otherpid && $otherpid) {
+ chomp $otherpid;
+ }
+ if (defined $otherhost && $otherhost) {
+ chomp $otherhost;
+ }
+ my $thishost = hostname();
+ if (defined $otherhost && defined $thishost &&
+ $otherhost ne '' && $thishost ne '' &&
+ $otherhost ne $thishost) {
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
+ "reports other host $otherhost and other ".
+ "process $otherpid.\n".
+ "Cannot proceed.\n"));
+ } elsif ($RUN_DEGRADED) {
+ $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n");
+ } elsif (defined $otherpid && $otherpid) {
+ return if $$ == $otherpid; # should never happen
+ $CPAN::Frontend->mywarn(
+ qq{
+There seems to be running another CPAN process (pid $otherpid). Contacting...
+});
+ if (kill 0, $otherpid or $!{EPERM}) {
+ $CPAN::Frontend->mywarn(qq{Other job is running.\n});
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Shall I try to run in downgraded }.
+ qq{mode? (Y/n)},"y");
+ if ($ans =~ /^y/i) {
+ $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
+Please report if something unexpected happens\n");
+ $RUN_DEGRADED = 1;
+ for ($CPAN::Config) {
+ # XXX
+ # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
+ $_->{commandnumber_in_prompt} = 0; # visibility
+ $_->{histfile} = ""; # who should win otherwise?
+ $_->{cache_metadata} = 0; # better would be a lock?
+ $_->{use_sqlite} = 0; # better would be a write lock!
+ $_->{auto_commit} = 0; # we are violent, do not persist
+ $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
+ }
+ } else {
+ $CPAN::Frontend->mydie("
+You may want to kill the other job and delete the lockfile. On UNIX try:
+ kill $otherpid
+ rm $lockfile
+");
+ }
+ } elsif (-w $lockfile) {
+ my($ans) =
+ CPAN::Shell::colorable_makemaker_prompt
+ (qq{Other job not responding. Shall I overwrite }.
+ qq{the lockfile '$lockfile'? (Y/n)},"y");
+ $CPAN::Frontend->myexit("Ok, bye\n")
+ unless $ans =~ /^y/i;
+ } else {
+ Carp::croak(
+ qq{Lockfile '$lockfile' not writable by you. }.
+ qq{Cannot proceed.\n}.
+ qq{ On UNIX try:\n}.
+ qq{ rm '$lockfile'\n}.
+ qq{ and then rerun us.\n}
+ );
+ }
+ } else {
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
+ "'$lockfile', please remove. Cannot proceed.\n"));
+ }
+ }
+ my $dotcpan = $CPAN::Config->{cpan_home};
+ eval { File::Path::mkpath($dotcpan);};
+ if ($@) {
+ # A special case at least for Jarkko.
+ my $firsterror = $@;
+ my $seconderror;
+ my $symlinkcpan;
+ if (-l $dotcpan) {
+ $symlinkcpan = readlink $dotcpan;
+ die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
+ eval { File::Path::mkpath($symlinkcpan); };
+ if ($@) {
+ $seconderror = $@;
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+Working directory $symlinkcpan created.
+});
+ }
+ }
+ unless (-d $dotcpan) {
+ my $mess = qq{
+Your configuration suggests "$dotcpan" as your
+CPAN.pm working directory. I could not create this directory due
+to this error: $firsterror\n};
+ $mess .= qq{
+As "$dotcpan" is a symlink to "$symlinkcpan",
+I tried to create that, but I failed with this error: $seconderror
+} if $seconderror;
+ $mess .= qq{
+Please make sure the directory exists and is writable.
+};
+ $CPAN::Frontend->mywarn($mess);
+ return suggest_myconfig;
+ }
+ } # $@ after eval mkpath $dotcpan
+ if (0) { # to test what happens when a race condition occurs
+ for (reverse 1..10) {
+ print $_, "\n";
+ sleep 1;
+ }
+ }
+ # locking
+ if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
+ my $fh;
+ unless ($fh = FileHandle->new("+>>$lockfile")) {
+ if ($! =~ /Permission/) {
+ $CPAN::Frontend->mywarn(qq{
+
+Your configuration suggests that CPAN.pm should use a working
+directory of
+ $CPAN::Config->{cpan_home}
+Unfortunately we could not create the lock file
+ $lockfile
+due to permission problems.
+
+Please make sure that the configuration variable
+ \$CPAN::Config->{cpan_home}
+points to a directory where you can write a .lock file. You can set
+this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
+\@INC path;
+});
+ return suggest_myconfig;
+ }
+ }
+ my $sleep = 1;
+ while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
+ if ($sleep>10) {
+ $CPAN::Frontend->mydie("Giving up\n");
+ }
+ $CPAN::Frontend->mysleep($sleep++);
+ $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
+ }
+
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ $fh->autoflush(1);
+ $fh->print($$, "\n");
+ $fh->print(hostname(), "\n");
+ $self->{LOCK} = $lockfile;
+ $self->{LOCKFH} = $fh;
+ }
+ $SIG{TERM} = sub {
+ my $sig = shift;
+ &cleanup;
+ $CPAN::Frontend->mydie("Got SIG$sig, leaving");
+ };
+ $SIG{INT} = sub {
+ # no blocks!!!
+ my $sig = shift;
+ &cleanup if $Signal;
+ die "Got yet another signal" if $Signal > 1;
+ $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
+ $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
+ $Signal++;
+ };
+
+# From: Larry Wall <larry@wall.org>
+# Subject: Re: deprecating SIGDIE
+# To: perl5-porters@perl.org
+# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
+#
+# The original intent of __DIE__ was only to allow you to substitute one
+# kind of death for another on an application-wide basis without respect
+# to whether you were in an eval or not. As a global backstop, it should
+# not be used any more lightly (or any more heavily :-) than class
+# UNIVERSAL. Any attempt to build a general exception model on it should
+# be politely squashed. Any bug that causes every eval {} to have to be
+# modified should be not so politely squashed.
+#
+# Those are my current opinions. It is also my optinion that polite
+# arguments degenerate to personal arguments far too frequently, and that
+# when they do, it's because both people wanted it to, or at least didn't
+# sufficiently want it not to.
+#
+# Larry
+
+ # global backstop to cleanup if we should really die
+ $SIG{__DIE__} = \&cleanup;
+ $self->debug("Signal handler set.") if $CPAN::DEBUG;
+}
+
+#-> sub CPAN::DESTROY ;
+sub DESTROY {
+ &cleanup; # need an eval?
+}
+
+#-> sub CPAN::anycwd ;
+sub anycwd () {
+ my $getcwd;
+ $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ CPAN->$getcwd();
+}
+
+#-> sub CPAN::cwd ;
+sub cwd {Cwd::cwd();}
+
+#-> sub CPAN::getcwd ;
+sub getcwd {Cwd::getcwd();}
+
+#-> sub CPAN::fastcwd ;
+sub fastcwd {Cwd::fastcwd();}
+
+#-> sub CPAN::backtickcwd ;
+sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
+
+#-> sub CPAN::find_perl ;
+sub find_perl () {
+ my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
+ unless ($perl) {
+ my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
+ $^X = $perl = $candidate if MM->maybe_command($candidate);
+ }
+ unless ($perl) {
+ my ($component,$perl_name);
+ DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
+ PATH_COMPONENT: foreach $component (File::Spec->path(),
+ $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $^X = $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
+ }
+ return $perl;
+}
+
+
+#-> sub CPAN::exists ;
+sub exists {
+ my($mgr,$class,$id) = @_;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ CPAN::Index->reload;
+ ### Carp::croak "exists called without class argument" unless $class;
+ $id ||= "";
+ $id =~ s/:+/::/g if $class eq "CPAN::Module";
+ my $exists;
+ if (CPAN::_sqlite_running) {
+ $exists = (exists $META->{readonly}{$class}{$id} or
+ $CPAN::SQLite->set($class, $id));
+ } else {
+ $exists = exists $META->{readonly}{$class}{$id};
+ }
+ $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
+}
+
+#-> sub CPAN::delete ;
+sub delete {
+ my($mgr,$class,$id) = @_;
+ delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
+ delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
+}
+
+#-> sub CPAN::has_usable
+# has_inst is sometimes too optimistic, we should replace it with this
+# has_usable whenever a case is given
+sub has_usable {
+ my($self,$mod,$message) = @_;
+ return 1 if $HAS_USABLE->{$mod};
+ my $has_inst = $self->has_inst($mod,$message);
+ return unless $has_inst;
+ my $usable;
+ $usable = {
+
+ #
+ # these subroutines die if they believe the installed version is unusable;
+ #
+
+ LWP => [ # we frequently had "Can't locate object
+ # method "new" via package "LWP::UserAgent" at
+ # (eval 69) line 2006
+ sub {require LWP},
+ sub {require LWP::UserAgent},
+ sub {require HTTP::Request},
+ sub {require URI::URL;
+ unless (CPAN::Version->vge(URI::URL::->VERSION,0.08)) {
+ for ("Will not use URI::URL, need 0.08\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ],
+ 'Net::FTP' => [
+ sub {require Net::FTP},
+ sub {require Net::Config},
+ ],
+ 'File::HomeDir' => [
+ sub {require File::HomeDir;
+ unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
+ for ("Will not use File::HomeDir, need 0.52\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ],
+ 'Archive::Tar' => [
+ sub {require Archive::Tar;
+ my $demand = "1.50";
+ unless (CPAN::Version->vge(Archive::Tar::->VERSION, $demand)) {
+ my $atv = Archive::Tar->VERSION;
+ for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") {
+ $CPAN::Frontend->mywarn($_);
+ # don't die, because we may need
+ # Archive::Tar to upgrade
+ }
+
+ }
+ },
+ ],
+ 'File::Temp' => [
+ # XXX we should probably delete from
+ # %INC too so we can load after we
+ # installed a new enough version --
+ # I'm not sure.
+ sub {require File::Temp;
+ unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
+ for ("Will not use File::Temp, need 0.16\n") {
+ $CPAN::Frontend->mywarn($_);
+ die $_;
+ }
+ }
+ },
+ ]
+ };
+ if ($usable->{$mod}) {
+ for my $c (0..$#{$usable->{$mod}}) {
+ my $code = $usable->{$mod}[$c];
+ my $ret = eval { &$code() };
+ $ret = "" unless defined $ret;
+ if ($@) {
+ # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
+ return;
+ }
+ }
+ }
+ return $HAS_USABLE->{$mod} = 1;
+}
+
+#-> sub CPAN::has_inst
+sub has_inst {
+ my($self,$mod,$message) = @_;
+ Carp::croak("CPAN->has_inst() called without an argument")
+ unless defined $mod;
+ my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
+ keys %{$CPAN::Config->{dontload_hash}||{}},
+ @{$CPAN::Config->{dontload_list}||[]};
+ if (defined $message && $message eq "no" # afair only used by Nox
+ ||
+ $dont{$mod}
+ ) {
+ $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
+ return 0;
+ }
+ my $file = $mod;
+ my $obj;
+ $file =~ s|::|/|g;
+ $file .= ".pm";
+ if ($INC{$file}) {
+ # checking %INC is wrong, because $INC{LWP} may be true
+ # although $INC{"URI/URL.pm"} may have failed. But as
+ # I really want to say "bla loaded OK", I have to somehow
+ # cache results.
+ ### warn "$file in %INC"; #debug
+ return 1;
+ } elsif (eval { require $file }) {
+ # eval is good: if we haven't yet read the database it's
+ # perfect and if we have installed the module in the meantime,
+ # it tries again. The second require is only a NOOP returning
+ # 1 if we had success, otherwise it's retrying
+
+ my $mtime = (stat $INC{$file})[9];
+ # privileged files loaded by has_inst; Note: we use $mtime
+ # as a proxy for a checksum.
+ $CPAN::Shell::reload->{$file} = $mtime;
+ my $v = eval "\$$mod\::VERSION";
+ $v = $v ? " (v$v)" : "";
+ CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
+ if ($mod eq "CPAN::WAIT") {
+ push @CPAN::Shell::ISA, 'CPAN::WAIT';
+ }
+ return 1;
+ } elsif ($mod eq "Net::FTP") {
+ $CPAN::Frontend->mywarn(qq{
+ Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
+ if you just type
+ install Bundle::libnet
+
+}) unless $Have_warned->{"Net::FTP"}++;
+ $CPAN::Frontend->mysleep(3);
+ } elsif ($mod eq "Digest::SHA") {
+ if ($Have_warned->{"Digest::SHA"}++) {
+ $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
+ qq{because Digest::SHA not installed.\n});
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+ CPAN: checksum security checks disabled because Digest::SHA not installed.
+ Please consider installing the Digest::SHA module.
+
+});
+ $CPAN::Frontend->mysleep(2);
+ }
+ } elsif ($mod eq "Module::Signature") {
+ # NOT prefs_lookup, we are not a distro
+ my $check_sigs = $CPAN::Config->{check_sigs};
+ if (not $check_sigs) {
+ # they do not want us:-(
+ } elsif (not $Have_warned->{"Module::Signature"}++) {
+ # No point in complaining unless the user can
+ # reasonably install and use it.
+ if (eval { require Crypt::OpenPGP; 1 } ||
+ (
+ defined $CPAN::Config->{'gpg'}
+ &&
+ $CPAN::Config->{'gpg'} =~ /\S/
+ )
+ ) {
+ $CPAN::Frontend->mywarn(qq{
+ CPAN: Module::Signature security checks disabled because Module::Signature
+ not installed. Please consider installing the Module::Signature module.
+ You may also need to be able to connect over the Internet to the public
+ keyservers like pgp.mit.edu (port 11371).
+
+});
+ $CPAN::Frontend->mysleep(2);
+ }
+ }
+ } else {
+ delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
+ }
+ return 0;
+}
+
+#-> sub CPAN::instance ;
+sub instance {
+ my($mgr,$class,$id) = @_;
+ CPAN::Index->reload;
+ $id ||= "";
+ # unsafe meta access, ok?
+ return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
+ $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
+}
+
+#-> sub CPAN::new ;
+sub new {
+ bless {}, shift;
+}
+
+#-> sub CPAN::cleanup ;
+sub cleanup {
+ # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
+ local $SIG{__DIE__} = '';
+ my($message) = @_;
+ my $i = 0;
+ my $ineval = 0;
+ my($subroutine);
+ while ((undef,undef,undef,$subroutine) = caller(++$i)) {
+ $ineval = 1, last if
+ $subroutine eq '(eval)';
+ }
+ return if $ineval && !$CPAN::End;
+ return unless defined $META->{LOCK};
+ return unless -f $META->{LOCK};
+ $META->savehist;
+ close $META->{LOCKFH};
+ unlink $META->{LOCK};
+ # require Carp;
+ # Carp::cluck("DEBUGGING");
+ if ( $CPAN::CONFIG_DIRTY ) {
+ $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
+ }
+ $CPAN::Frontend->myprint("Lockfile removed.\n");
+}
+
+#-> sub CPAN::readhist
+sub readhist {
+ my($self,$term,$histfile) = @_;
+ my $histsize = $CPAN::Config->{'histsize'} || 100;
+ $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
+ my($fh) = FileHandle->new;
+ open $fh, "<$histfile" or return;
+ local $/ = "\n";
+ while (<$fh>) {
+ chomp;
+ $term->AddHistory($_);
+ }
+ close $fh;
+}
+
+#-> sub CPAN::savehist
+sub savehist {
+ my($self) = @_;
+ my($histfile,$histsize);
+ unless ($histfile = $CPAN::Config->{'histfile'}) {
+ $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
+ return;
+ }
+ $histsize = $CPAN::Config->{'histsize'} || 100;
+ if ($CPAN::term) {
+ unless ($CPAN::term->can("GetHistory")) {
+ $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
+ return;
+ }
+ } else {
+ return;
+ }
+ my @h = $CPAN::term->GetHistory;
+ splice @h, 0, @h-$histsize if @h>$histsize;
+ my($fh) = FileHandle->new;
+ open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
+ local $\ = local $, = "\n";
+ print $fh @h;
+ close $fh;
+}
+
+#-> sub CPAN::is_tested
+sub is_tested {
+ my($self,$what,$when) = @_;
+ unless ($what) {
+ Carp::cluck("DEBUG: empty what");
+ return;
+ }
+ $self->{is_tested}{$what} = $when;
+}
+
+#-> sub CPAN::reset_tested
+# forget all distributions tested -- resets what gets included in PERL5LIB
+sub reset_tested {
+ my ($self) = @_;
+ $self->{is_tested} = {};
+}
+
+#-> sub CPAN::is_installed
+# unsets the is_tested flag: as soon as the thing is installed, it is
+# not needed in set_perl5lib anymore
+sub is_installed {
+ my($self,$what) = @_;
+ delete $self->{is_tested}{$what};
+}
+
+sub _list_sorted_descending_is_tested {
+ my($self) = @_;
+ sort
+ { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
+ keys %{$self->{is_tested}}
+}
+
+#-> sub CPAN::set_perl5lib
+# Notes on max environment variable length:
+# - Win32 : XP or later, 8191; Win2000 or NT4, 2047
+{
+my $fh;
+sub set_perl5lib {
+ my($self,$for) = @_;
+ unless ($for) {
+ (undef,undef,undef,$for) = caller(1);
+ $for =~ s/.*://;
+ }
+ $self->{is_tested} ||= {};
+ return unless %{$self->{is_tested}};
+ my $env = $ENV{PERL5LIB};
+ $env = $ENV{PERLLIB} unless defined $env;
+ my @env;
+ push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
+ #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
+ #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
+
+ my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
+ return if !@dirs;
+
+ if (@dirs < 12) {
+ $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ } elsif (@dirs < 24 ) {
+ my @d = map {my $cp = $_;
+ $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
+ $cp
+ } @dirs;
+ $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
+ "%BUILDDIR%=$CPAN::Config->{build_dir} ".
+ "for '$for'\n"
+ );
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ } else {
+ my $cnt = keys %{$self->{is_tested}};
+ $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
+ "$cnt build dirs to PERL5LIB; ".
+ "for '$for'\n"
+ );
+ $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+ }
+}}
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+CPAN - query, download and build perl modules from CPAN sites
+
+=head1 SYNOPSIS
+
+Interactive mode:
+
+ perl -MCPAN -e shell
+
+--or--
+
+ cpan
+
+Basic commands:
+
+ # Modules:
+
+ cpan> install Acme::Meta # in the shell
+
+ CPAN::Shell->install("Acme::Meta"); # in perl
+
+ # Distributions:
+
+ cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
+
+ CPAN::Shell->
+ install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
+
+ # module objects:
+
+ $mo = CPAN::Shell->expandany($mod);
+ $mo = CPAN::Shell->expand("Module",$mod); # same thing
+
+ # distribution objects:
+
+ $do = CPAN::Shell->expand("Module",$mod)->distribution;
+ $do = CPAN::Shell->expandany($distro); # same thing
+ $do = CPAN::Shell->expand("Distribution",
+ $distro); # same thing
+
+=head1 DESCRIPTION
+
+The CPAN module automates or at least simplifies the make and install
+of perl modules and extensions. It includes some primitive searching
+capabilities and knows how to use Net::FTP, LWP, and certain external
+download clients to fetch distributions from the net.
+
+These are fetched from one or more mirrored CPAN (Comprehensive
+Perl Archive Network) sites and unpacked in a dedicated directory.
+
+The CPAN module also supports named and versioned
+I<bundles> of modules. Bundles simplify handling of sets of
+related modules. See Bundles below.
+
+The package contains a session manager and a cache manager. The
+session manager keeps track of what has been fetched, built, and
+installed in the current session. The cache manager keeps track of the
+disk space occupied by the make processes and deletes excess space
+using a simple FIFO mechanism.
+
+All methods provided are accessible in a programmer style and in an
+interactive shell style.
+
+=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
+
+Enter interactive mode by running
+
+ perl -MCPAN -e shell
+
+or
+
+ cpan
+
+which puts you into a readline interface. If C<Term::ReadKey> and
+either of C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed,
+history and command completion are supported.
+
+Once at the command line, type C<h> for one-page help
+screen; the rest should be self-explanatory.
+
+The function call C<shell> takes two optional arguments: one the
+prompt, the second the default initial command line (the latter
+only works if a real ReadLine interface module is installed).
+
+The most common uses of the interactive modes are
+
+=over 2
+
+=item Searching for authors, bundles, distribution files and modules
+
+There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
+for each of the four categories and another, C<i> for any of the
+mentioned four. Each of the four entities is implemented as a class
+with slightly differing methods for displaying an object.
+
+Arguments to these commands are either strings exactly matching
+the identification string of an object, or regular expressions
+matched case-insensitively against various attributes of the
+objects. The parser only recognizes a regular expression when you
+enclose it with slashes.
+
+The principle is that the number of objects found influences how an
+item is displayed. If the search finds one item, the result is
+displayed with the rather verbose method C<as_string>, but if
+more than one is found, each object is displayed with the terse method
+C<as_glimpse>.
+
+Examples:
+
+ cpan> m Acme::MetaSyntactic
+ Module id = Acme::MetaSyntactic
+ CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
+ CPAN_VERSION 0.99
+ CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ UPLOAD_DATE 2006-11-06
+ MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names
+ INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
+ INST_VERSION 0.99
+ cpan> a BOOK
+ Author id = BOOK
+ EMAIL [...]
+ FULLNAME Philippe Bruhat (BooK)
+ cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
+ CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
+ CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
+ UPLOAD_DATE 2006-11-06
+ cpan> m /lorem/
+ Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
+ Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz)
+ Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
+ Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
+ cpan> i /berlin/
+ Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz
+ Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
+ Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz)
+ Author [...]
+
+The examples illustrate several aspects: the first three queries
+target modules, authors, or distros directly and yield exactly one
+result. The last two use regular expressions and yield several
+results. The last one targets all of bundles, modules, authors, and
+distros simultaneously. When more than one result is available, they
+are printed in one-line format.
+
+=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
+
+These commands take any number of arguments and investigate what is
+necessary to perform the action. Argument processing is as follows:
+
+ known module name in format Foo/Bar.pm module
+ other embedded slash distribution
+ - with trailing slash dot directory
+ enclosing slashes regexp
+ known module name in format Foo::Bar module
+
+If the argument is a distribution file name (recognized by embedded
+slashes), it is processed. If it is a module, CPAN determines the
+distribution file in which this module is included and processes that,
+following any dependencies named in the module's META.yml or
+Makefile.PL (this behavior is controlled by the configuration
+parameter C<prerequisites_policy>). If an argument is enclosed in
+slashes it is treated as a regular expression: it is expanded and if
+the result is a single object (distribution, bundle or module), this
+object is processed.
+
+Example:
+
+ install Dummy::Perl # installs the module
+ install AUXXX/Dummy-Perl-3.14.tar.gz # installs that distribution
+ install /Dummy-Perl-3.14/ # same if the regexp is unambiguous
+
+C<get> downloads a distribution file and untars or unzips it, C<make>
+builds it, C<test> runs the test suite, and C<install> installs it.
+
+Any C<make> or C<test> is run unconditionally. An
+
+ install <distribution_file>
+
+is also run unconditionally. But for
+
+ install <module>
+
+CPAN checks whether an install is needed and prints
+I<module up to date> if the distribution file containing
+the module doesn't need updating.
+
+CPAN also keeps track of what it has done within the current session
+and doesn't try to build a package a second time regardless of whether it
+succeeded or not. It does not repeat a test run if the test
+has been run successfully before. Same for install runs.
+
+The C<force> pragma may precede another command (currently: C<get>,
+C<make>, C<test>, or C<install>) to execute the command from scratch
+and attempt to continue past certain errors. See the section below on
+the C<force> and the C<fforce> pragma.
+
+The C<notest> pragma skips the test part in the build
+process.
+
+Example:
+
+ cpan> notest install Tk
+
+A C<clean> command results in a
+
+ make clean
+
+being executed within the distribution file's working directory.
+
+=item C<readme>, C<perldoc>, C<look> module or distribution
+
+C<readme> displays the README file of the associated distribution.
+C<Look> gets and untars (if not yet done) the distribution file,
+changes to the appropriate directory and opens a subshell process in
+that directory. C<perldoc> displays the module's pod documentation
+in html or plain text format.
+
+=item C<ls> author
+
+=item C<ls> globbing_expression
+
+The first form lists all distribution files in and below an author's
+CPAN directory as stored in the CHECKUMS files distributed on
+CPAN. The listing recurses into subdirectories.
+
+The second form limits or expands the output with shell
+globbing as in the following examples:
+
+ ls JV/make*
+ ls GSAR/*make*
+ ls */*make*
+
+The last example is very slow and outputs extra progress indicators
+that break the alignment of the result.
+
+Note that globbing only lists directories explicitly asked for, for
+example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
+regarded as a bug that may be changed in some future version.
+
+=item C<failed>
+
+The C<failed> command reports all distributions that failed on one of
+C<make>, C<test> or C<install> for some reason in the currently
+running shell session.
+
+=item Persistence between sessions
+
+If the C<YAML> or the C<YAML::Syck> module is installed a record of
+the internal state of all modules is written to disk after each step.
+The files contain a signature of the currently running perl version
+for later perusal.
+
+If the configurations variable C<build_dir_reuse> is set to a true
+value, then CPAN.pm reads the collected YAML files. If the stored
+signature matches the currently running perl, the stored state is
+loaded into memory such that persistence between sessions
+is effectively established.
+
+=item The C<force> and the C<fforce> pragma
+
+To speed things up in complex installation scenarios, CPAN.pm keeps
+track of what it has already done and refuses to do some things a
+second time. A C<get>, a C<make>, and an C<install> are not repeated.
+A C<test> is repeated only if the previous test was unsuccessful. The
+diagnostic message when CPAN.pm refuses to do something a second time
+is one of I<Has already been >C<unwrapped|made|tested successfully> or
+something similar. Another situation where CPAN refuses to act is an
+C<install> if the corresponding C<test> was not successful.
+
+In all these cases, the user can override this stubborn behaviour by
+prepending the command with the word force, for example:
+
+ cpan> force get Foo
+ cpan> force make AUTHOR/Bar-3.14.tar.gz
+ cpan> force test Baz
+ cpan> force install Acme::Meta
+
+Each I<forced> command is executed with the corresponding part of its
+memory erased.
+
+The C<fforce> pragma is a variant that emulates a C<force get> which
+erases the entire memory followed by the action specified, effectively
+restarting the whole get/make/test/install procedure from scratch.
+
+=item Lockfile
+
+Interactive sessions maintain a lockfile, by default C<~/.cpan/.lock>.
+Batch jobs can run without a lockfile and not disturb each other.
+
+The shell offers to run in I<downgraded mode> when another process is
+holding the lockfile. This is an experimental feature that is not yet
+tested very well. This second shell then does not write the history
+file, does not use the metadata file, and has a different prompt.
+
+=item Signals
+
+CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
+in the cpan-shell, it is intended that you can press C<^C> anytime and
+return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
+to clean up and leave the shell loop. You can emulate the effect of a
+SIGTERM by sending two consecutive SIGINTs, which usually means by
+pressing C<^C> twice.
+
+CPAN.pm ignores SIGPIPE. If the user sets C<inactivity_timeout>, a
+SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
+Build.PL> subprocess. A SIGALRM is also used during module version
+parsing, and is controlled by C<version_timeout>.
+
+=back
+
+=head2 CPAN::Shell
+
+The commands available in the shell interface are methods in
+the package CPAN::Shell. If you enter the shell command, your
+input is split by the Text::ParseWords::shellwords() routine, which
+acts like most shells do. The first word is interpreted as the
+method to be invoked, and the rest of the words are treated as the method's arguments.
+Continuation lines are supported by ending a line with a
+literal backslash.
+
+=head2 autobundle
+
+C<autobundle> writes a bundle file into the
+C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
+a list of all modules that are both available from CPAN and currently
+installed within @INC. The name of the bundle file is based on the
+current date and a counter.
+
+=head2 hosts
+
+Note: this feature is still in alpha state and may change in future
+versions of CPAN.pm
+
+This commands provides a statistical overview over recent download
+activities. The data for this is collected in the YAML file
+C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
+configured or YAML not installed, no stats are provided.
+
+=head2 mkmyconfig
+
+mkmyconfig() writes your own CPAN::MyConfig file into your C<~/.cpan/>
+directory so that you can save your own preferences instead of the
+system-wide ones.
+
+=head2 recent ***EXPERIMENTAL COMMAND***
+
+The C<recent> command downloads a list of recent uploads to CPAN and
+displays them I<slowly>. While the command is running, a $SIG{INT}
+exits the loop after displaying the current item.
+
+B<Note>: This command requires XML::LibXML installed.
+
+B<Note>: This whole command currently is just a hack and will
+probably change in future versions of CPAN.pm, but the general
+approach will likely remain.
+
+B<Note>: See also L<smoke>
+
+=head2 recompile
+
+recompile() is a special command that takes no argument and
+runs the make/test/install cycle with brute force over all installed
+dynamically loadable extensions (aka XS modules) with 'force' in
+effect. The primary purpose of this command is to finish a network
+installation. Imagine you have a common source tree for two different
+architectures. You decide to do a completely independent fresh
+installation. You start on one architecture with the help of a Bundle
+file produced earlier. CPAN installs the whole Bundle for you, but
+when you try to repeat the job on the second architecture, CPAN
+responds with a C<"Foo up to date"> message for all modules. So you
+invoke CPAN's recompile on the second architecture and you're done.
+
+Another popular use for C<recompile> is to act as a rescue in case your
+perl breaks binary compatibility. If one of the modules that CPAN uses
+is in turn depending on binary compatibility (so you cannot run CPAN
+commands), then you should try the CPAN::Nox module for recovery.
+
+=head2 report Bundle|Distribution|Module
+
+The C<report> command temporarily turns on the C<test_report> config
+variable, then runs the C<force test> command with the given
+arguments. The C<force> pragma reruns the tests and repeats
+every step that might have failed before.
+
+=head2 smoke ***EXPERIMENTAL COMMAND***
+
+B<*** WARNING: this command downloads and executes software from CPAN to
+your computer of completely unknown status. You should never do
+this with your normal account and better have a dedicated well
+separated and secured machine to do this. ***>
+
+The C<smoke> command takes the list of recent uploads to CPAN as
+provided by the C<recent> command and tests them all. While the
+command is running $SIG{INT} is defined to mean that the current item
+shall be skipped.
+
+B<Note>: This whole command currently is just a hack and will
+probably change in future versions of CPAN.pm, but the general
+approach will likely remain.
+
+B<Note>: See also L<recent>
+
+=head2 upgrade [Module|/Regex/]...
+
+The C<upgrade> command first runs an C<r> command with the given
+arguments and then installs the newest versions of all modules that
+were listed by that.
+
+=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
+
+Although it may be considered internal, the class hierarchy does matter
+for both users and programmer. CPAN.pm deals with the four
+classes mentioned above, and those classes all share a set of methods. Classical
+single polymorphism is in effect. A metaclass object registers all
+objects of all kinds and indexes them with a string. The strings
+referencing objects have a separated namespace (well, not completely
+separated):
+
+ Namespace Class
+
+ words containing a "/" (slash) Distribution
+ words starting with Bundle:: Bundle
+ everything else Module or Author
+
+Modules know their associated Distribution objects. They always refer
+to the most recent official release. Developers may mark their releases
+as unstable development versions (by inserting an underbar into the
+module version number which will also be reflected in the distribution
+name when you run 'make dist'), so the really hottest and newest
+distribution is not always the default. If a module Foo circulates
+on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
+way to install version 1.23 by saying
+
+ install Foo
+
+This would install the complete distribution file (say
+BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
+like to install version 1.23_90, you need to know where the
+distribution file resides on CPAN relative to the authors/id/
+directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
+so you would have to say
+
+ install BAR/Foo-1.23_90.tar.gz
+
+The first example will be driven by an object of the class
+CPAN::Module, the second by an object of class CPAN::Distribution.
+
+=head2 Integrating local directories
+
+Note: this feature is still in alpha state and may change in future
+versions of CPAN.pm
+
+Distribution objects are normally distributions from the CPAN, but
+there is a slightly degenerate case for Distribution objects, too, of
+projects held on the local disk. These distribution objects have the
+same name as the local directory and end with a dot. A dot by itself
+is also allowed for the current directory at the time CPAN.pm was
+used. All actions such as C<make>, C<test>, and C<install> are applied
+directly to that directory. This gives the command C<cpan .> an
+interesting touch: while the normal mantra of installing a CPAN module
+without CPAN.pm is one of
+
+ perl Makefile.PL perl Build.PL
+ ( go and get prerequisites )
+ make ./Build
+ make test ./Build test
+ make install ./Build install
+
+the command C<cpan .> does all of this at once. It figures out which
+of the two mantras is appropriate, fetches and installs all
+prerequisites, takes care of them recursively, and finally finishes the
+installation of the module in the current directory, be it a CPAN
+module or not.
+
+The typical usage case is for private modules or working copies of
+projects from remote repositories on the local disk.
+
+=head2 Redirection
+
+The usual shell redirection symbols C< | > and C<< > >> are recognized
+by the cpan shell B<only when surrounded by whitespace>. So piping to
+pager or redirecting output into a file works somewhat as in a normal
+shell, with the stipulation that you must type extra spaces.
+
+=head1 CONFIGURATION
+
+When the CPAN module is used for the first time, a configuration
+dialogue tries to determine a couple of site specific options. The
+result of the dialog is stored in a hash reference C< $CPAN::Config >
+in a file CPAN/Config.pm.
+
+Default values defined in the CPAN/Config.pm file can be
+overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
+best placed in C<$HOME/.cpan/CPAN/MyConfig.pm>, because C<$HOME/.cpan> is
+added to the search path of the CPAN module before the use() or
+require() statements. The mkmyconfig command writes this file for you.
+
+The C<o conf> command has various bells and whistles:
+
+=over
+
+=item completion support
+
+If you have a ReadLine module installed, you can hit TAB at any point
+of the commandline and C<o conf> will offer you completion for the
+built-in subcommands and/or config variable names.
+
+=item displaying some help: o conf help
+
+Displays a short help
+
+=item displaying current values: o conf [KEY]
+
+Displays the current value(s) for this config variable. Without KEY,
+displays all subcommands and config variables.
+
+Example:
+
+ o conf shell
+
+If KEY starts and ends with a slash, the string in between is
+treated as a regular expression and only keys matching this regex
+are displayed
+
+Example:
+
+ o conf /color/
+
+=item changing of scalar values: o conf KEY VALUE
+
+Sets the config variable KEY to VALUE. The empty string can be
+specified as usual in shells, with C<''> or C<"">
+
+Example:
+
+ o conf wget /usr/bin/wget
+
+=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
+
+If a config variable name ends with C<list>, it is a list. C<o conf
+KEY shift> removes the first element of the list, C<o conf KEY pop>
+removes the last element of the list. C<o conf KEYS unshift LIST>
+prepends a list of values to the list, C<o conf KEYS push LIST>
+appends a list of valued to the list.
+
+Likewise, C<o conf KEY splice LIST> passes the LIST to the corresponding
+splice command.
+
+Finally, any other list of arguments is taken as a new list value for
+the KEY variable discarding the previous value.
+
+Examples:
+
+ o conf urllist unshift http://cpan.dev.local/CPAN
+ o conf urllist splice 3 1
+ o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
+
+=item reverting to saved: o conf defaults
+
+Reverts all config variables to the state in the saved config file.
+
+=item saving the config: o conf commit
+
+Saves all config variables to the current config file (CPAN/Config.pm
+or CPAN/MyConfig.pm that was loaded at start).
+
+=back
+
+The configuration dialog can be started any time later again by
+issuing the command C< o conf init > in the CPAN shell. A subset of
+the configuration dialog can be run by issuing C<o conf init WORD>
+where WORD is any valid config variable or a regular expression.
+
+=head2 Config Variables
+
+The following keys in the hash reference $CPAN::Config are
+currently defined:
+
+ applypatch path to external prg
+ auto_commit commit all changes to config variables to disk
+ build_cache size of cache for directories to build modules
+ build_dir locally accessible directory to build modules
+ build_dir_reuse boolean if distros in build_dir are persistent
+ build_requires_install_policy
+ to install or not to install when a module is
+ only needed for building. yes|no|ask/yes|ask/no
+ bzip2 path to external prg
+ cache_metadata use serializer to cache metadata
+ check_sigs if signatures should be verified
+ colorize_debug Term::ANSIColor attributes for debugging output
+ colorize_output boolean if Term::ANSIColor should colorize output
+ colorize_print Term::ANSIColor attributes for normal output
+ colorize_warn Term::ANSIColor attributes for warnings
+ commandnumber_in_prompt
+ boolean if you want to see current command number
+ commands_quote preferred character to use for quoting external
+ commands when running them. Defaults to double
+ quote on Windows, single tick everywhere else;
+ can be set to space to disable quoting
+ connect_to_internet_ok
+ whether to ask if opening a connection is ok before
+ urllist is specified
+ cpan_home local directory reserved for this package
+ curl path to external prg
+ dontload_hash DEPRECATED
+ dontload_list arrayref: modules in the list will not be
+ loaded by the CPAN::has_inst() routine
+ ftp path to external prg
+ ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
+ ftp_proxy proxy host for ftp requests
+ ftpstats_period max number of days to keep download statistics
+ ftpstats_size max number of items to keep in the download statistics
+ getcwd see below
+ gpg path to external prg
+ gzip location of external program gzip
+ halt_on_failure stop processing after the first failure of queued
+ items or dependencies
+ histfile file to maintain history between sessions
+ histsize maximum number of lines to keep in histfile
+ http_proxy proxy host for http requests
+ inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
+ after this many seconds inactivity. Set to 0 to
+ disable timeouts.
+ index_expire refetch index files after this many days
+ inhibit_startup_message
+ if true, suppress the startup message
+ keep_source_where directory in which to keep the source (if we do)
+ load_module_verbosity
+ report loading of optional modules used by CPAN.pm
+ lynx path to external prg
+ make location of external make program
+ make_arg arguments that should always be passed to 'make'
+ make_install_make_command
+ the make command for running 'make install', for
+ example 'sudo make'
+ make_install_arg same as make_arg for 'make install'
+ makepl_arg arguments passed to 'perl Makefile.PL'
+ mbuild_arg arguments passed to './Build'
+ mbuild_install_arg arguments passed to './Build install'
+ mbuild_install_build_command
+ command to use instead of './Build' when we are
+ in the install stage, for example 'sudo ./Build'
+ mbuildpl_arg arguments passed to 'perl Build.PL'
+ ncftp path to external prg
+ ncftpget path to external prg
+ no_proxy don't proxy to these hosts/domains (comma separated list)
+ pager location of external program more (or any pager)
+ password your password if you CPAN server wants one
+ patch path to external prg
+ patches_dir local directory containing patch files
+ perl5lib_verbosity verbosity level for PERL5LIB additions
+ prefer_installer legal values are MB and EUMM: if a module comes
+ with both a Makefile.PL and a Build.PL, use the
+ former (EUMM) or the latter (MB); if the module
+ comes with only one of the two, that one will be
+ used no matter the setting
+ prerequisites_policy
+ what to do if you are missing module prerequisites
+ ('follow' automatically, 'ask' me, or 'ignore')
+ For 'follow', also sets PERL_AUTOINSTALL and
+ PERL_EXTUTILS_AUTOINSTALL for "--defaultdeps" if
+ not already set
+ prefs_dir local directory to store per-distro build options
+ proxy_user username for accessing an authenticating proxy
+ proxy_pass password for accessing an authenticating proxy
+ randomize_urllist add some randomness to the sequence of the urllist
+ scan_cache controls scanning of cache ('atstart' or 'never')
+ shell your favorite shell
+ show_unparsable_versions
+ boolean if r command tells which modules are versionless
+ show_upload_date boolean if commands should try to determine upload date
+ show_zero_versions boolean if r command tells for which modules $version==0
+ tar location of external program tar
+ tar_verbosity verbosity level for the tar command
+ term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
+ (and nonsense for characters outside latin range)
+ term_ornaments boolean to turn ReadLine ornamenting on/off
+ test_report email test reports (if CPAN::Reporter is installed)
+ trust_test_report_history
+ skip testing when previously tested ok (according to
+ CPAN::Reporter history)
+ unzip location of external program unzip
+ urllist arrayref to nearby CPAN sites (or equivalent locations)
+ use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
+ username your username if you CPAN server wants one
+ version_timeout stops version parsing after this many seconds.
+ Default is 15 secs. Set to 0 to disable.
+ wait_list arrayref to a wait server to try (See CPAN::WAIT)
+ wget path to external prg
+ yaml_load_code enable YAML code deserialisation via CPAN::DeferredCode
+ yaml_module which module to use to read/write YAML files
+
+You can set and query each of these options interactively in the cpan
+shell with the C<o conf> or the C<o conf init> command as specified below.
+
+=over 2
+
+=item C<o conf E<lt>scalar optionE<gt>>
+
+prints the current value of the I<scalar option>
+
+=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
+
+Sets the value of the I<scalar option> to I<value>
+
+=item C<o conf E<lt>list optionE<gt>>
+
+prints the current value of the I<list option> in MakeMaker's
+neatvalue format.
+
+=item C<o conf E<lt>list optionE<gt> [shift|pop]>
+
+shifts or pops the array in the I<list option> variable
+
+=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
+
+works like the corresponding perl commands.
+
+=item interactive editing: o conf init [MATCH|LIST]
+
+Runs an interactive configuration dialog for matching variables.
+Without argument runs the dialog over all supported config variables.
+To specify a MATCH the argument must be enclosed by slashes.
+
+Examples:
+
+ o conf init ftp_passive ftp_proxy
+ o conf init /color/
+
+Note: this method of setting config variables often provides more
+explanation about the functioning of a variable than the manpage.
+
+=back
+
+=head2 CPAN::anycwd($path): Note on config variable getcwd
+
+CPAN.pm changes the current working directory often and needs to
+determine its own current working directory. By default it uses
+Cwd::cwd, but if for some reason this doesn't work on your system,
+configure alternatives according to the following table:
+
+=over 4
+
+=item cwd
+
+Calls Cwd::cwd
+
+=item getcwd
+
+Calls Cwd::getcwd
+
+=item fastcwd
+
+Calls Cwd::fastcwd
+
+=item backtickcwd
+
+Calls the external command cwd.
+
+=back
+
+=head2 Note on the format of the urllist parameter
+
+urllist parameters are URLs according to RFC 1738. We do a little
+guessing if your URL is not compliant, but if you have problems with
+C<file> URLs, please try the correct format. Either:
+
+ file://localhost/whatever/ftp/pub/CPAN/
+
+or
+
+ file:///home/ftp/pub/CPAN/
+
+=head2 The urllist parameter has CD-ROM support
+
+The C<urllist> parameter of the configuration table contains a list of
+URLs used for downloading. If the list contains any
+C<file> URLs, CPAN always tries there first. This
+feature is disabled for index files. So the recommendation for the
+owner of a CD-ROM with CPAN contents is: include your local, possibly
+outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
+
+ o conf urllist push file://localhost/CDROM/CPAN
+
+CPAN.pm will then fetch the index files from one of the CPAN sites
+that come at the beginning of urllist. It will later check for each
+module to see whether there is a local copy of the most recent version.
+
+Another peculiarity of urllist is that the site that we could
+successfully fetch the last file from automatically gets a preference
+token and is tried as the first site for the next request. So if you
+add a new site at runtime it may happen that the previously preferred
+site will be tried another time. This means that if you want to disallow
+a site for the next transfer, it must be explicitly removed from
+urllist.
+
+=head2 Maintaining the urllist parameter
+
+If you have YAML.pm (or some other YAML module configured in
+C<yaml_module>) installed, CPAN.pm collects a few statistical data
+about recent downloads. You can view the statistics with the C<hosts>
+command or inspect them directly by looking into the C<FTPstats.yml>
+file in your C<cpan_home> directory.
+
+To get some interesting statistics, it is recommended that
+C<randomize_urllist> be set; this introduces some amount of
+randomness into the URL selection.
+
+=head2 The C<requires> and C<build_requires> dependency declarations
+
+Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
+a distribution are treated differently depending on the config
+variable C<build_requires_install_policy>. By setting
+C<build_requires_install_policy> to C<no>, such a module is not
+installed. It is only built and tested, and then kept in the list of
+tested but uninstalled modules. As such, it is available during the
+build of the dependent module by integrating the path to the
+C<blib/arch> and C<blib/lib> directories in the environment variable
+PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
+both modules declared as C<requires> and those declared as
+C<build_requires> are treated alike. By setting to C<ask/yes> or
+C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
+
+=head2 Configuration for individual distributions (I<Distroprefs>)
+
+(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
+still considered beta quality)
+
+Distributions on CPAN usually behave according to what we call the
+CPAN mantra. Or since the advent of Module::Build we should talk about
+two mantras:
+
+ perl Makefile.PL perl Build.PL
+ make ./Build
+ make test ./Build test
+ make install ./Build install
+
+But some modules cannot be built with this mantra. They try to get
+some extra data from the user via the environment, extra arguments, or
+interactively--thus disturbing the installation of large bundles like
+Phalanx100 or modules with many dependencies like Plagger.
+
+The distroprefs system of C<CPAN.pm> addresses this problem by
+allowing the user to specify extra informations and recipes in YAML
+files to either
+
+=over
+
+=item
+
+pass additional arguments to one of the four commands,
+
+=item
+
+set environment variables
+
+=item
+
+instantiate an Expect object that reads from the console, waits for
+some regular expressions and enters some answers
+
+=item
+
+temporarily override assorted C<CPAN.pm> configuration variables
+
+=item
+
+specify dependencies the original maintainer forgot
+
+=item
+
+disable the installation of an object altogether
+
+=back
+
+See the YAML and Data::Dumper files that come with the C<CPAN.pm>
+distribution in the C<distroprefs/> directory for examples.
+
+=head2 Filenames
+
+The YAML files themselves must have the C<.yml> extension; all other
+files are ignored (for two exceptions see I<Fallback Data::Dumper and
+Storable> below). The containing directory can be specified in
+C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
+prefs_dir> in the CPAN shell to set and activate the distroprefs
+system.
+
+Every YAML file may contain arbitrary documents according to the YAML
+specification, and every document is treated as an entity that
+can specify the treatment of a single distribution.
+
+Filenames can be picked arbitrarily; C<CPAN.pm> always reads
+all files (in alphabetical order) and takes the key C<match> (see
+below in I<Language Specs>) as a hashref containing match criteria
+that determine if the current distribution matches the YAML document
+or not.
+
+=head2 Fallback Data::Dumper and Storable
+
+If neither your configured C<yaml_module> nor YAML.pm is installed,
+CPAN.pm falls back to using Data::Dumper and Storable and looks for
+files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
+directory. These files are expected to contain one or more hashrefs.
+For Data::Dumper generated files, this is expected to be done with by
+defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
+with the command
+
+ ysh < somefile.yml > somefile.dd
+
+For Storable files the rule is that they must be constructed such that
+C<Storable::retrieve(file)> returns an array reference and the array
+elements represent one distropref object each. The conversion from
+YAML would look like so:
+
+ perl -MYAML=LoadFile -MStorable=nstore -e '
+ @y=LoadFile(shift);
+ nstore(\@y, shift)' somefile.yml somefile.st
+
+In bootstrapping situations it is usually sufficient to translate only
+a few YAML files to Data::Dumper for crucial modules like
+C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
+over Data::Dumper, remember to pull out a Storable version that writes
+an older format than all the other Storable versions that will need to
+read them.
+
+=head2 Blueprint
+
+The following example contains all supported keywords and structures
+with the exception of C<eexpect> which can be used instead of
+C<expect>.
+
+ ---
+ comment: "Demo"
+ match:
+ module: "Dancing::Queen"
+ distribution: "^CHACHACHA/Dancing-"
+ not_distribution: "\.zip$"
+ perl: "/usr/local/cariba-perl/bin/perl"
+ perlconfig:
+ archname: "freebsd"
+ not_cc: "gcc"
+ env:
+ DANCING_FLOOR: "Shubiduh"
+ disabled: 1
+ cpanconfig:
+ make: gmake
+ pl:
+ args:
+ - "--somearg=specialcase"
+
+ env: {}
+
+ expect:
+ - "Which is your favorite fruit"
+ - "apple\n"
+
+ make:
+ args:
+ - all
+ - extra-all
+
+ env: {}
+
+ expect: []
+
+ commandline: "echo SKIPPING make"
+
+ test:
+ args: []
+
+ env: {}
+
+ expect: []
+
+ install:
+ args: []
+
+ env:
+ WANT_TO_INSTALL: YES
+
+ expect:
+ - "Do you really want to install"
+ - "y\n"
+
+ patches:
+ - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
+
+ depends:
+ configure_requires:
+ LWP: 5.8
+ build_requires:
+ Test::Exception: 0.25
+ requires:
+ Spiffy: 0.30
+
+
+=head2 Language Specs
+
+Every YAML document represents a single hash reference. The valid keys
+in this hash are as follows:
+
+=over
+
+=item comment [scalar]
+
+A comment
+
+=item cpanconfig [hash]
+
+Temporarily override assorted C<CPAN.pm> configuration variables.
+
+Supported are: C<build_requires_install_policy>, C<check_sigs>,
+C<make>, C<make_install_make_command>, C<prefer_installer>,
+C<test_report>. Please report as a bug when you need another one
+supported.
+
+=item depends [hash] *** EXPERIMENTAL FEATURE ***
+
+All three types, namely C<configure_requires>, C<build_requires>, and
+C<requires> are supported in the way specified in the META.yml
+specification. The current implementation I<merges> the specified
+dependencies with those declared by the package maintainer. In a
+future implementation this may be changed to override the original
+declaration.
+
+=item disabled [boolean]
+
+Specifies that this distribution shall not be processed at all.
+
+=item features [array] *** EXPERIMENTAL FEATURE ***
+
+Experimental implementation to deal with optional_features from
+META.yml. Still needs coordination with installer software and
+currently works only for META.yml declaring C<dynamic_config=0>. Use
+with caution.
+
+=item goto [string]
+
+The canonical name of a delegate distribution to install
+instead. Useful when a new version, although it tests OK itself,
+breaks something else or a developer release or a fork is already
+uploaded that is better than the last released version.
+
+=item install [hash]
+
+Processing instructions for the C<make install> or C<./Build install>
+phase of the CPAN mantra. See below under I<Processing Instructions>.
+
+=item make [hash]
+
+Processing instructions for the C<make> or C<./Build> phase of the
+CPAN mantra. See below under I<Processing Instructions>.
+
+=item match [hash]
+
+A hashref with one or more of the keys C<distribution>, C<modules>,
+C<perl>, C<perlconfig>, and C<env> that specify whether a document is
+targeted at a specific CPAN distribution or installation.
+Keys prefixed with C<not_> negates the corresponding match.
+
+The corresponding values are interpreted as regular expressions. The
+C<distribution> related one will be matched against the canonical
+distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
+
+The C<module> related one will be matched against I<all> modules
+contained in the distribution until one module matches.
+
+The C<perl> related one will be matched against C<$^X> (but with the
+absolute path).
+
+The value associated with C<perlconfig> is itself a hashref that is
+matched against corresponding values in the C<%Config::Config> hash
+living in the C<Config.pm> module.
+Keys prefixed with C<not_> negates the corresponding match.
+
+The value associated with C<env> is itself a hashref that is
+matched against corresponding values in the C<%ENV> hash.
+Keys prefixed with C<not_> negates the corresponding match.
+
+If more than one restriction of C<module>, C<distribution>, etc. is
+specified, the results of the separately computed match values must
+all match. If so, the hashref represented by the
+YAML document is returned as the preference structure for the current
+distribution.
+
+=item patches [array]
+
+An array of patches on CPAN or on the local disk to be applied in
+order via an external patch program. If the value for the C<-p>
+parameter is C<0> or C<1> is determined by reading the patch
+beforehand. The path to each patch is either an absolute path on the
+local filesystem or relative to a patch directory specified in the
+C<patches_dir> configuration variable or in the format of a canonical
+distroname. For examples please consult the distroprefs/ directory in
+the CPAN.pm distribution (these examples are not installed by
+default).
+
+Note: if the C<applypatch> program is installed and C<CPAN::Config>
+knows about it B<and> a patch is written by the C<makepatch> program,
+then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
+and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
+distribution.
+
+=item pl [hash]
+
+Processing instructions for the C<perl Makefile.PL> or C<perl
+Build.PL> phase of the CPAN mantra. See below under I<Processing
+Instructions>.
+
+=item test [hash]
+
+Processing instructions for the C<make test> or C<./Build test> phase
+of the CPAN mantra. See below under I<Processing Instructions>.
+
+=back
+
+=head2 Processing Instructions
+
+=over
+
+=item args [array]
+
+Arguments to be added to the command line
+
+=item commandline
+
+A full commandline to run via C<system()>.
+During execution, the environment variable PERL is set
+to $^X (but with an absolute path). If C<commandline> is specified,
+C<args> is not used.
+
+=item eexpect [hash]
+
+Extended C<expect>. This is a hash reference with four allowed keys,
+C<mode>, C<timeout>, C<reuse>, and C<talk>.
+
+You must install the C<Expect> module to use C<eexpect>. CPAN.pm
+does not install it for you.
+
+C<mode> may have the values C<deterministic> for the case where all
+questions come in the order written down and C<anyorder> for the case
+where the questions may come in any order. The default mode is
+C<deterministic>.
+
+C<timeout> denotes a timeout in seconds. Floating-point timeouts are
+OK. With C<mode=deterministic>, the timeout denotes the
+timeout per question; with C<mode=anyorder> it denotes the
+timeout per byte received from the stream or questions.
+
+C<talk> is a reference to an array that contains alternating questions
+and answers. Questions are regular expressions and answers are literal
+strings. The Expect module watches the stream from the
+execution of the external program (C<perl Makefile.PL>, C<perl
+Build.PL>, C<make>, etc.).
+
+For C<mode=deterministic>, the CPAN.pm injects the
+corresponding answer as soon as the stream matches the regular expression.
+
+For C<mode=anyorder> CPAN.pm answers a question as soon
+as the timeout is reached for the next byte in the input stream. In
+this mode you can use the C<reuse> parameter to decide what will
+happen with a question-answer pair after it has been used. In the
+default case (reuse=0) it is removed from the array, avoiding being
+used again accidentally. If you want to answer the
+question C<Do you really want to do that> several times, then it must
+be included in the array at least as often as you want this answer to
+be given. Setting the parameter C<reuse> to 1 makes this repetition
+unnecessary.
+
+=item env [hash]
+
+Environment variables to be set during the command
+
+=item expect [array]
+
+You must install the C<Expect> module to use C<expect>. CPAN.pm
+does not install it for you.
+
+C<< expect: <array> >> is a short notation for this C<eexpect>:
+
+ eexpect:
+ mode: deterministic
+ timeout: 15
+ talk: <array>
+
+=back
+
+=head2 Schema verification with C<Kwalify>
+
+If you have the C<Kwalify> module installed (which is part of the
+Bundle::CPANxxl), then all your distroprefs files are checked for
+syntactic correctness.
+
+=head2 Example Distroprefs Files
+
+C<CPAN.pm> comes with a collection of example YAML files. Note that these
+are really just examples and should not be used without care because
+they cannot fit everybody's purpose. After all, the authors of the
+packages that ask questions had a need to ask, so you should watch
+their questions and adjust the examples to your environment and your
+needs. You have been warned:-)
+
+=head1 PROGRAMMER'S INTERFACE
+
+If you do not enter the shell, shell commands are
+available both as methods (C<CPAN::Shell-E<gt>install(...)>) and as
+functions in the calling package (C<install(...)>). Before calling low-level
+commands, it makes sense to initialize components of CPAN you need, e.g.:
+
+ CPAN::HandleConfig->load;
+ CPAN::Shell::setup_output;
+ CPAN::Index->reload;
+
+High-level commands do such initializations automatically.
+
+There's currently only one class that has a stable interface -
+CPAN::Shell. All commands that are available in the CPAN shell are
+methods of the class CPAN::Shell. Each of the commands that produce
+listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
+the IDs of all modules within the list.
+
+=over 2
+
+=item expand($type,@things)
+
+The IDs of all objects available within a program are strings that can
+be expanded to the corresponding real objects with the
+C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
+list of CPAN::Module objects according to the C<@things> arguments
+given. In scalar context, it returns only the first element of the
+list.
+
+=item expandany(@things)
+
+Like expand, but returns objects of the appropriate type, i.e.
+CPAN::Bundle objects for bundles, CPAN::Module objects for modules, and
+CPAN::Distribution objects for distributions. Note: it does not expand
+to CPAN::Author objects.
+
+=item Programming Examples
+
+This enables the programmer to do operations that combine
+functionalities that are available in the shell.
+
+ # install everything that is outdated on my disk:
+ perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
+
+ # install my favorite programs if necessary:
+ for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
+ CPAN::Shell->install($mod);
+ }
+
+ # list all modules on my disk that have no VERSION number
+ for $mod (CPAN::Shell->expand("Module","/./")) {
+ next unless $mod->inst_file;
+ # MakeMaker convention for undefined $VERSION:
+ next unless $mod->inst_version eq "undef";
+ print "No VERSION in ", $mod->id, "\n";
+ }
+
+ # find out which distribution on CPAN contains a module:
+ print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
+
+Or if you want to schedule a I<cron> job to watch CPAN, you could list
+all modules that need updating. First a quick and dirty way:
+
+ perl -e 'use CPAN; CPAN::Shell->r;'
+
+If you don't want any output should all modules be
+up to date, parse the output of above command for the regular
+expression C</modules are up to date/> and decide to mail the output
+only if it doesn't match.
+
+If you prefer to do it more in a programmerish style in one single
+process, something like this may better suit you:
+
+ # list all modules on my disk that have newer versions on CPAN
+ for $mod (CPAN::Shell->expand("Module","/./")) {
+ next unless $mod->inst_file;
+ next if $mod->uptodate;
+ printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
+ $mod->id, $mod->inst_version, $mod->cpan_version;
+ }
+
+If that gives too much output every day, you may want to
+watch only for three modules. You can write
+
+ for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
+
+as the first line instead. Or you can combine some of the above
+tricks:
+
+ # watch only for a new mod_perl module
+ $mod = CPAN::Shell->expand("Module","mod_perl");
+ exit if $mod->uptodate;
+ # new mod_perl arrived, let me know all update recommendations
+ CPAN::Shell->r;
+
+=back
+
+=head2 Methods in the other Classes
+
+=over 4
+
+=item CPAN::Author::as_glimpse()
+
+Returns a one-line description of the author
+
+=item CPAN::Author::as_string()
+
+Returns a multi-line description of the author
+
+=item CPAN::Author::email()
+
+Returns the author's email address
+
+=item CPAN::Author::fullname()
+
+Returns the author's name
+
+=item CPAN::Author::name()
+
+An alias for fullname
+
+=item CPAN::Bundle::as_glimpse()
+
+Returns a one-line description of the bundle
+
+=item CPAN::Bundle::as_string()
+
+Returns a multi-line description of the bundle
+
+=item CPAN::Bundle::clean()
+
+Recursively runs the C<clean> method on all items contained in the bundle.
+
+=item CPAN::Bundle::contains()
+
+Returns a list of objects' IDs contained in a bundle. The associated
+objects may be bundles, modules or distributions.
+
+=item CPAN::Bundle::force($method,@args)
+
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. The C<force> is passed recursively
+to all contained objects. See also the section above on the C<force>
+and the C<fforce> pragma.
+
+=item CPAN::Bundle::get()
+
+Recursively runs the C<get> method on all items contained in the bundle
+
+=item CPAN::Bundle::inst_file()
+
+Returns the highest installed version of the bundle in either @INC or
+C<< $CPAN::Config->{cpan_home} >>. Note that this is different from
+CPAN::Module::inst_file.
+
+=item CPAN::Bundle::inst_version()
+
+Like CPAN::Bundle::inst_file, but returns the $VERSION
+
+=item CPAN::Bundle::uptodate()
+
+Returns 1 if the bundle itself and all its members are uptodate.
+
+=item CPAN::Bundle::install()
+
+Recursively runs the C<install> method on all items contained in the bundle
+
+=item CPAN::Bundle::make()
+
+Recursively runs the C<make> method on all items contained in the bundle
+
+=item CPAN::Bundle::readme()
+
+Recursively runs the C<readme> method on all items contained in the bundle
+
+=item CPAN::Bundle::test()
+
+Recursively runs the C<test> method on all items contained in the bundle
+
+=item CPAN::Distribution::as_glimpse()
+
+Returns a one-line description of the distribution
+
+=item CPAN::Distribution::as_string()
+
+Returns a multi-line description of the distribution
+
+=item CPAN::Distribution::author
+
+Returns the CPAN::Author object of the maintainer who uploaded this
+distribution
+
+=item CPAN::Distribution::pretty_id()
+
+Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
+author's PAUSE ID and TARBALL is the distribution filename.
+
+=item CPAN::Distribution::base_id()
+
+Returns the distribution filename without any archive suffix. E.g
+"Foo-Bar-0.01"
+
+=item CPAN::Distribution::clean()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make clean> there.
+
+=item CPAN::Distribution::containsmods()
+
+Returns a list of IDs of modules contained in a distribution file.
+Works only for distributions listed in the 02packages.details.txt.gz
+file. This typically means that just most recent version of a
+distribution is covered.
+
+=item CPAN::Distribution::cvs_import()
+
+Changes to the directory where the distribution has been unpacked and
+runs something like
+
+ cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
+
+there.
+
+=item CPAN::Distribution::dir()
+
+Returns the directory into which this distribution has been unpacked.
+
+=item CPAN::Distribution::force($method,@args)
+
+Forces CPAN to perform a task that it normally would have refused to
+do. Force takes as arguments a method name to be called and any number
+of additional arguments that should be passed to the called method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. See also the section above on the
+C<force> and the C<fforce> pragma.
+
+=item CPAN::Distribution::get()
+
+Downloads the distribution from CPAN and unpacks it. Does nothing if
+the distribution has already been downloaded and unpacked within the
+current session.
+
+=item CPAN::Distribution::install()
+
+Changes to the directory where the distribution has been unpacked and
+runs the external command C<make install> there. If C<make> has not
+yet been run, it will be run first. A C<make test> is issued in
+any case and if this fails, the install is cancelled. The
+cancellation can be avoided by letting C<force> run the C<install> for
+you.
+
+This install method only has the power to install the distribution if
+there are no dependencies in the way. To install an object along with all
+its dependencies, use CPAN::Shell->install.
+
+Note that install() gives no meaningful return value. See uptodate().
+
+=item CPAN::Distribution::install_tested()
+
+Install all distributions that have tested sucessfully but
+not yet installed. See also C<is_tested>.
+
+=item CPAN::Distribution::isa_perl()
+
+Returns 1 if this distribution file seems to be a perl distribution.
+Normally this is derived from the file name only, but the index from
+CPAN can contain a hint to achieve a return value of true for other
+filenames too.
+
+=item CPAN::Distribution::look()
+
+Changes to the directory where the distribution has been unpacked and
+opens a subshell there. Exiting the subshell returns.
+
+=item CPAN::Distribution::make()
+
+First runs the C<get> method to make sure the distribution is
+downloaded and unpacked. Changes to the directory where the
+distribution has been unpacked and runs the external commands C<perl
+Makefile.PL> or C<perl Build.PL> and C<make> there.
+
+=item CPAN::Distribution::perldoc()
+
+Downloads the pod documentation of the file associated with a
+distribution (in HTML format) and runs it through the external
+command I<lynx> specified in C<< $CPAN::Config->{lynx} >>. If I<lynx>
+isn't available, it converts it to plain text with the external
+command I<html2text> and runs it through the pager specified
+in C<< $CPAN::Config->{pager} >>.
+
+=item CPAN::Distribution::prefs()
+
+Returns the hash reference from the first matching YAML file that the
+user has deposited in the C<prefs_dir/> directory. The first
+succeeding match wins. The files in the C<prefs_dir/> are processed
+alphabetically, and the canonical distroname (e.g.
+AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
+stored in the $root->{match}{distribution} attribute value.
+Additionally all module names contained in a distribution are matched
+against the regular expressions in the $root->{match}{module} attribute
+value. The two match values are ANDed together. Each of the two
+attributes are optional.
+
+=item CPAN::Distribution::prereq_pm()
+
+Returns the hash reference that has been announced by a distribution
+as the C<requires> and C<build_requires> elements. These can be
+declared either by the C<META.yml> (if authoritative) or can be
+deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
+or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
+a comment in the produced C<Makefile>. I<Note>: this method only works
+after an attempt has been made to C<make> the distribution. Returns
+undef otherwise.
+
+=item CPAN::Distribution::readme()
+
+Downloads the README file associated with a distribution and runs it
+through the pager specified in C<< $CPAN::Config->{pager} >>.
+
+=item CPAN::Distribution::reports()
+
+Downloads report data for this distribution from www.cpantesters.org
+and displays a subset of them.
+
+=item CPAN::Distribution::read_yaml()
+
+Returns the content of the META.yml of this distro as a hashref. Note:
+works only after an attempt has been made to C<make> the distribution.
+Returns undef otherwise. Also returns undef if the content of META.yml
+is not authoritative. (The rules about what exactly makes the content
+authoritative are still in flux.)
+
+=item CPAN::Distribution::test()
+
+Changes to the directory where the distribution has been unpacked and
+runs C<make test> there.
+
+=item CPAN::Distribution::uptodate()
+
+Returns 1 if all the modules contained in the distribution are
+uptodate. Relies on containsmods.
+
+=item CPAN::Index::force_reload()
+
+Forces a reload of all indices.
+
+=item CPAN::Index::reload()
+
+Reloads all indices if they have not been read for more than
+C<< $CPAN::Config->{index_expire} >> days.
+
+=item CPAN::InfoObj::dump()
+
+CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
+inherit this method. It prints the data structure associated with an
+object. Useful for debugging. Note: the data structure is considered
+internal and thus subject to change without notice.
+
+=item CPAN::Module::as_glimpse()
+
+Returns a one-line description of the module in four columns: The
+first column contains the word C<Module>, the second column consists
+of one character: an equals sign if this module is already installed
+and uptodate, a less-than sign if this module is installed but can be
+upgraded, and a space if the module is not installed. The third column
+is the name of the module and the fourth column gives maintainer or
+distribution information.
+
+=item CPAN::Module::as_string()
+
+Returns a multi-line description of the module
+
+=item CPAN::Module::clean()
+
+Runs a clean on the distribution associated with this module.
+
+=item CPAN::Module::cpan_file()
+
+Returns the filename on CPAN that is associated with the module.
+
+=item CPAN::Module::cpan_version()
+
+Returns the latest version of this module available on CPAN.
+
+=item CPAN::Module::cvs_import()
+
+Runs a cvs_import on the distribution associated with this module.
+
+=item CPAN::Module::description()
+
+Returns a 44 character description of this module. Only available for
+modules listed in The Module List (CPAN/modules/00modlist.long.html
+or 00modlist.long.txt.gz)
+
+=item CPAN::Module::distribution()
+
+Returns the CPAN::Distribution object that contains the current
+version of this module.
+
+=item CPAN::Module::dslip_status()
+
+Returns a hash reference. The keys of the hash are the letters C<D>,
+C<S>, C<L>, C<I>, and <P>, for development status, support level,
+language, interface and public licence respectively. The data for the
+DSLIP status are collected by pause.perl.org when authors register
+their namespaces. The values of the 5 hash elements are one-character
+words whose meaning is described in the table below. There are also 5
+hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
+verbose value of the 5 status variables.
+
+Where the 'DSLIP' characters have the following meanings:
+
+ D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
+ i - Idea, listed to gain consensus or as a placeholder
+ c - under construction but pre-alpha (not yet released)
+ a/b - Alpha/Beta testing
+ R - Released
+ M - Mature (no rigorous definition)
+ S - Standard, supplied with Perl 5
+
+ S - Support Level:
+ m - Mailing-list
+ d - Developer
+ u - Usenet newsgroup comp.lang.perl.modules
+ n - None known, try comp.lang.perl.modules
+ a - abandoned; volunteers welcome to take over maintainance
+
+ L - Language Used:
+ p - Perl-only, no compiler needed, should be platform independent
+ c - C and perl, a C compiler will be needed
+ h - Hybrid, written in perl with optional C code, no compiler needed
+ + - C++ and perl, a C++ compiler will be needed
+ o - perl and another language other than C or C++
+
+ I - Interface Style
+ f - plain Functions, no references used
+ h - hybrid, object and function interfaces available
+ n - no interface at all (huh?)
+ r - some use of unblessed References or ties
+ O - Object oriented using blessed references and/or inheritance
+
+ P - Public License
+ p - Standard-Perl: user may choose between GPL and Artistic
+ g - GPL: GNU General Public License
+ l - LGPL: "GNU Lesser General Public License" (previously known as
+ "GNU Library General Public License")
+ b - BSD: The BSD License
+ a - Artistic license alone
+ 2 - Artistic license 2.0 or later
+ o - open source: appoved by www.opensource.org
+ d - allows distribution without restrictions
+ r - restricted distribtion
+ n - no license at all
+
+=item CPAN::Module::force($method,@args)
+
+Forces CPAN to perform a task it would normally refuse to
+do. Force takes as arguments a method name to be invoked and any number
+of additional arguments to pass that method.
+The internals of the object get the needed changes so that CPAN.pm
+does not refuse to take the action. See also the section above on the
+C<force> and the C<fforce> pragma.
+
+=item CPAN::Module::get()
+
+Runs a get on the distribution associated with this module.
+
+=item CPAN::Module::inst_file()
+
+Returns the filename of the module found in @INC. The first file found
+is reported, just as perl itself stops searching @INC once it finds a
+module.
+
+=item CPAN::Module::available_file()
+
+Returns the filename of the module found in PERL5LIB or @INC. The
+first file found is reported. The advantage of this method over
+C<inst_file> is that modules that have been tested but not yet
+installed are included because PERL5LIB keeps track of tested modules.
+
+=item CPAN::Module::inst_version()
+
+Returns the version number of the installed module in readable format.
+
+=item CPAN::Module::available_version()
+
+Returns the version number of the available module in readable format.
+
+=item CPAN::Module::install()
+
+Runs an C<install> on the distribution associated with this module.
+
+=item CPAN::Module::look()
+
+Changes to the directory where the distribution associated with this
+module has been unpacked and opens a subshell there. Exiting the
+subshell returns.
+
+=item CPAN::Module::make()
+
+Runs a C<make> on the distribution associated with this module.
+
+=item CPAN::Module::manpage_headline()
+
+If module is installed, peeks into the module's manpage, reads the
+headline, and returns it. Moreover, if the module has been downloaded
+within this session, does the equivalent on the downloaded module even
+if it hasn't been installed yet.
+
+=item CPAN::Module::perldoc()
+
+Runs a C<perldoc> on this module.
+
+=item CPAN::Module::readme()
+
+Runs a C<readme> on the distribution associated with this module.
+
+=item CPAN::Module::reports()
+
+Calls the reports() method on the associated distribution object.
+
+=item CPAN::Module::test()
+
+Runs a C<test> on the distribution associated with this module.
+
+=item CPAN::Module::uptodate()
+
+Returns 1 if the module is installed and up-to-date.
+
+=item CPAN::Module::userid()
+
+Returns the author's ID of the module.
+
+=back
+
+=head2 Cache Manager
+
+Currently the cache manager only keeps track of the build directory
+($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
+deletes complete directories below C<build_dir> as soon as the size of
+all directories there gets bigger than $CPAN::Config->{build_cache}
+(in MB). The contents of this cache may be used for later
+re-installations that you intend to do manually, but will never be
+trusted by CPAN itself. This is due to the fact that the user might
+use these directories for building modules on different architectures.
+
+There is another directory ($CPAN::Config->{keep_source_where}) where
+the original distribution files are kept. This directory is not
+covered by the cache manager and must be controlled by the user. If
+you choose to have the same directory as build_dir and as
+keep_source_where directory, then your sources will be deleted with
+the same fifo mechanism.
+
+=head2 Bundles
+
+A bundle is just a perl module in the namespace Bundle:: that does not
+define any functions or methods. It usually only contains documentation.
+
+It starts like a perl module with a package declaration and a $VERSION
+variable. After that the pod section looks like any other pod with the
+only difference being that I<one special pod section> exists starting with
+(verbatim):
+
+ =head1 CONTENTS
+
+In this pod section each line obeys the format
+
+ Module_Name [Version_String] [- optional text]
+
+The only required part is the first field, the name of a module
+(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
+of the line is optional. The comment part is delimited by a dash just
+as in the man page header.
+
+The distribution of a bundle should follow the same convention as
+other distributions.
+
+Bundles are treated specially in the CPAN package. If you say 'install
+Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
+the modules in the CONTENTS section of the pod. You can install your
+own Bundles locally by placing a conformant Bundle file somewhere into
+your @INC path. The autobundle() command which is available in the
+shell interface does that for you by including all currently installed
+modules in a snapshot bundle file.
+
+=head1 PREREQUISITES
+
+The CPAN program is trying to depend on as little as possible so the
+user can use it in hostile enviroment. It works better the more goodies
+the environment provides. For example if you try in the CPAN shell
+
+ install Bundle::CPAN
+
+or
+
+ install Bundle::CPANxxl
+
+you will find the shell more convenient than the bare shell before.
+
+If you have a local mirror of CPAN and can access all files with
+"file:" URLs, then you only need a perl later than perl5.003 to run
+this module. Otherwise Net::FTP is strongly recommended. LWP may be
+required for non-UNIX systems, or if your nearest CPAN site is
+associated with a URL that is not C<ftp:>.
+
+If you have neither Net::FTP nor LWP, there is a fallback mechanism
+implemented for an external ftp command or for an external lynx
+command.
+
+=head1 UTILITIES
+
+=head2 Finding packages and VERSION
+
+This module presumes that all packages on CPAN
+
+=over 2
+
+=item *
+
+declare their $VERSION variable in an easy to parse manner. This
+prerequisite can hardly be relaxed because it consumes far too much
+memory to load all packages into the running program just to determine
+the $VERSION variable. Currently all programs that are dealing with
+version use something like this
+
+ perl -MExtUtils::MakeMaker -le \
+ 'print MM->parse_version(shift)' filename
+
+If you are author of a package and wonder if your $VERSION can be
+parsed, please try the above method.
+
+=item *
+
+come as compressed or gzipped tarfiles or as zip files and contain a
+C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
+with little enthusiasm).
+
+=back
+
+=head2 Debugging
+
+Debugging this module is more than a bit complex due to interference from
+the software producing the indices on CPAN, the mirroring process on CPAN,
+packaging, configuration, synchronicity, and even (gasp!) due to bugs
+within the CPAN.pm module itself.
+
+For debugging the code of CPAN.pm itself in interactive mode, some
+debugging aid can be turned on for most packages within
+CPAN.pm with one of
+
+=over 2
+
+=item o debug package...
+
+sets debug mode for packages.
+
+=item o debug -package...
+
+unsets debug mode for packages.
+
+=item o debug all
+
+turns debugging on for all packages.
+
+=item o debug number
+
+=back
+
+which sets the debugging packages directly. Note that C<o debug 0>
+turns debugging off.
+
+What seems a successful strategy is the combination of C<reload
+cpan> and the debugging switches. Add a new debug statement while
+running in the shell and then issue a C<reload cpan> and see the new
+debugging messages immediately without losing the current context.
+
+C<o debug> without an argument lists the valid package names and the
+current set of packages in debugging mode. C<o debug> has built-in
+completion support.
+
+For debugging of CPAN data there is the C<dump> command which takes
+the same arguments as make/test/install and outputs each object's
+Data::Dumper dump. If an argument looks like a perl variable and
+contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
+Data::Dumper directly.
+
+=head2 Floppy, Zip, Offline Mode
+
+CPAN.pm works nicely without network access, too. If you maintain machines
+that are not networked at all, you should consider working with C<file:>
+URLs. You'll have to collect your modules somewhere first. So
+you might use CPAN.pm to put together all you need on a networked
+machine. Then copy the $CPAN::Config->{keep_source_where} (but not
+$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
+of a personal CPAN. CPAN.pm on the non-networked machines works nicely
+with this floppy. See also below the paragraph about CD-ROM support.
+
+=head2 Basic Utilities for Programmers
+
+=over 2
+
+=item has_inst($module)
+
+Returns true if the module is installed. Used to load all modules into
+the running CPAN.pm that are considered optional. The config variable
+C<dontload_list> intercepts the C<has_inst()> call such
+that an optional module is not loaded despite being available. For
+example, the following command will prevent C<YAML.pm> from being
+loaded:
+
+ cpan> o conf dontload_list push YAML
+
+See the source for details.
+
+=item has_usable($module)
+
+Returns true if the module is installed and in a usable state. Only
+useful for a handful of modules that are used internally. See the
+source for details.
+
+=item instance($module)
+
+The constructor for all the singletons used to represent modules,
+distributions, authors, and bundles. If the object already exists, this
+method returns the object; otherwise, it calls the constructor.
+
+=back
+
+=head1 SECURITY
+
+There's no strong security layer in CPAN.pm. CPAN.pm helps you to
+install foreign, unmasked, unsigned code on your machine. We compare
+to a checksum that comes from the net just as the distribution file
+itself. But we try to make it easy to add security on demand:
+
+=head2 Cryptographically signed modules
+
+Since release 1.77, CPAN.pm has been able to verify cryptographically
+signed module distributions using Module::Signature. The CPAN modules
+can be signed by their authors, thus giving more security. The simple
+unsigned MD5 checksums that were used before by CPAN protect mainly
+against accidental file corruption.
+
+You will need to have Module::Signature installed, which in turn
+requires that you have at least one of Crypt::OpenPGP module or the
+command-line F<gpg> tool installed.
+
+You will also need to be able to connect over the Internet to the public
+keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
+
+The configuration parameter check_sigs is there to turn signature
+checking on or off.
+
+=head1 EXPORT
+
+Most functions in package CPAN are exported by default. The reason
+for this is that the primary use is intended for the cpan shell or for
+one-liners.
+
+=head1 ENVIRONMENT
+
+When the CPAN shell enters a subshell via the look command, it sets
+the environment CPAN_SHELL_LEVEL to 1, or increments that variable if it is
+already set.
+
+When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
+to the ID of the running process. It also sets
+PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
+happen with older versions of Module::Install.
+
+When running C<perl Makefile.PL>, the environment variable
+C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
+C<Makefile.PL> that is being executed. This prevents runaway processes
+with newer versions of Module::Install.
+
+When the config variable ftp_passive is set, all downloads will be run
+with the environment variable FTP_PASSIVE set to this value. This is
+in general a good idea as it influences both Net::FTP and LWP based
+connections. The same effect can be achieved by starting the cpan
+shell with this environment variable set. For Net::FTP alone, one can
+also always set passive mode by running libnetcfg.
+
+=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
+
+Populating a freshly installed perl with one's favorite modules is pretty
+easy if you maintain a private bundle definition file. To get a useful
+blueprint of a bundle definition file, the command autobundle can be used
+on the CPAN shell command line. This command writes a bundle definition
+file for all modules installed for the current perl
+interpreter. It's recommended to run this command once only, and from then
+on maintain the file manually under a private name, say
+Bundle/my_bundle.pm. With a clever bundle file you can then simply say
+
+ cpan> install Bundle::my_bundle
+
+then answer a few questions and go out for coffee (possibly
+even in a different city).
+
+Maintaining a bundle definition file means keeping track of two
+things: dependencies and interactivity. CPAN.pm sometimes fails on
+calculating dependencies because not all modules define all MakeMaker
+attributes correctly, so a bundle definition file should specify
+prerequisites as early as possible. On the other hand, it's
+annoying that so many distributions need some interactive configuring. So
+what you can try to accomplish in your private bundle file is to have the
+packages that need to be configured early in the file and the gentle
+ones later, so you can go out for cofeee after a few minutes and leave CPAN.pm
+to churn away untended.
+
+=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
+
+Thanks to Graham Barr for contributing the following paragraphs about
+the interaction between perl, and various firewall configurations. For
+further information on firewalls, it is recommended to consult the
+documentation that comes with the I<ncftp> program. If you are unable to
+go through the firewall with a simple Perl setup, it is likely
+that you can configure I<ncftp> so that it works through your firewall.
+
+=head2 Three basic types of firewalls
+
+Firewalls can be categorized into three basic types.
+
+=over 4
+
+=item http firewall
+
+This is when the firewall machine runs a web server, and to access the
+outside world, you must do so via that web server. If you set environment
+variables like http_proxy or ftp_proxy to values beginning with http://,
+or in your web browser you've proxy information set, then you know
+you are running behind an http firewall.
+
+To access servers outside these types of firewalls with perl (even for
+ftp), you need LWP.
+
+=item ftp firewall
+
+This where the firewall machine runs an ftp server. This kind of
+firewall will only let you access ftp servers outside the firewall.
+This is usually done by connecting to the firewall with ftp, then
+entering a username like "user@outside.host.com".
+
+To access servers outside these type of firewalls with perl, you
+need Net::FTP.
+
+=item One-way visibility
+
+One-way visibility means these firewalls try to make themselves
+invisible to users inside the firewall. An FTP data connection is
+normally created by sending your IP address to the remote server and then
+listening for the return connection. But the remote server will not be able to
+connect to you because of the firewall. For these types of firewall,
+FTP connections need to be done in a passive mode.
+
+There are two that I can think off.
+
+=over 4
+
+=item SOCKS
+
+If you are using a SOCKS firewall, you will need to compile perl and link
+it with the SOCKS library. This is what is normally called a 'socksified'
+perl. With this executable you will be able to connect to servers outside
+the firewall as if it were not there.
+
+=item IP Masquerade
+
+This is when the firewall implemented in the kernel (via NAT, or networking
+address translation), it allows you to hide a complete network behind one
+IP address. With this firewall no special compiling is needed as you can
+access hosts directly.
+
+For accessing ftp servers behind such firewalls you usually need to
+set the environment variable C<FTP_PASSIVE> or the config variable
+ftp_passive to a true value.
+
+=back
+
+=back
+
+=head2 Configuring lynx or ncftp for going through a firewall
+
+If you can go through your firewall with e.g. lynx, presumably with a
+command such as
+
+ /usr/local/bin/lynx -pscott:tiger
+
+then you would configure CPAN.pm with the command
+
+ o conf lynx "/usr/local/bin/lynx -pscott:tiger"
+
+That's all. Similarly for ncftp or ftp, you would configure something
+like
+
+ o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
+
+Your mileage may vary...
+
+=head1 FAQ
+
+=over 4
+
+=item 1)
+
+I installed a new version of module X but CPAN keeps saying,
+I have the old version installed
+
+Probably you B<do> have the old version installed. This can
+happen if a module installs itself into a different directory in the
+@INC path than it was previously installed. This is not really a
+CPAN.pm problem, you would have the same problem when installing the
+module manually. The easiest way to prevent this behaviour is to add
+the argument C<UNINST=1> to the C<make install> call, and that is why
+many people add this argument permanently by configuring
+
+ o conf make_install_arg UNINST=1
+
+=item 2)
+
+So why is UNINST=1 not the default?
+
+Because there are people who have their precise expectations about who
+may install where in the @INC path and who uses which @INC array. In
+fine tuned environments C<UNINST=1> can cause damage.
+
+=item 3)
+
+I want to clean up my mess, and install a new perl along with
+all modules I have. How do I go about it?
+
+Run the autobundle command for your old perl and optionally rename the
+resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
+with the Configure option prefix, e.g.
+
+ ./Configure -Dprefix=/usr/local/perl-5.6.78.9
+
+Install the bundle file you produced in the first step with something like
+
+ cpan> install Bundle::mybundle
+
+and you're done.
+
+=item 4)
+
+When I install bundles or multiple modules with one command
+there is too much output to keep track of.
+
+You may want to configure something like
+
+ o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
+ o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
+
+so that STDOUT is captured in a file for later inspection.
+
+
+=item 5)
+
+I am not root, how can I install a module in a personal directory?
+
+First of all, you will want to use your own configuration, not the one
+that your root user installed. If you do not have permission to write
+in the cpan directory that root has configured, you will be asked if
+you want to create your own config. Answering "yes" will bring you into
+CPAN's configuration stage, using the system config for all defaults except
+things that have to do with CPAN's work directory, saving your choices to
+your MyConfig.pm file.
+
+You can also manually initiate this process with the following command:
+
+ % perl -MCPAN -e 'mkmyconfig'
+
+or by running
+
+ mkmyconfig
+
+from the CPAN shell.
+
+You will most probably also want to configure something like this:
+
+ o conf makepl_arg "LIB=~/myperl/lib \
+ INSTALLMAN1DIR=~/myperl/man/man1 \
+ INSTALLMAN3DIR=~/myperl/man/man3 \
+ INSTALLSCRIPT=~/myperl/bin \
+ INSTALLBIN=~/myperl/bin"
+
+and then the equivalent command for Module::Build, which is
+
+ o conf mbuildpl_arg "--lib=~/myperl/lib \
+ --installman1dir=~/myperl/man/man1 \
+ --installman3dir=~/myperl/man/man3 \
+ --installscript=~/myperl/bin \
+ --installbin=~/myperl/bin"
+
+You can make this setting permanent like all C<o conf> settings with
+C<o conf commit> or by setting C<auto_commit> beforehand.
+
+You will have to add ~/myperl/man to the MANPATH environment variable
+and also tell your perl programs to look into ~/myperl/lib, e.g. by
+including
+
+ use lib "$ENV{HOME}/myperl/lib";
+
+or setting the PERL5LIB environment variable.
+
+While we're speaking about $ENV{HOME}, it might be worth mentioning,
+that for Windows we use the File::HomeDir module that provides an
+equivalent to the concept of the home directory on Unix.
+
+Another thing you should bear in mind is that the UNINST parameter can
+be dangerous when you are installing into a private area because you
+might accidentally remove modules that other people depend on that are
+not using the private area.
+
+=item 6)
+
+How to get a package, unwrap it, and make a change before building it?
+
+Have a look at the C<look> (!) command.
+
+=item 7)
+
+I installed a Bundle and had a couple of fails. When I
+retried, everything resolved nicely. Can this be fixed to work
+on first try?
+
+The reason for this is that CPAN does not know the dependencies of all
+modules when it starts out. To decide about the additional items to
+install, it just uses data found in the META.yml file or the generated
+Makefile. An undetected missing piece breaks the process. But it may
+well be that your Bundle installs some prerequisite later than some
+depending item and thus your second try is able to resolve everything.
+Please note, CPAN.pm does not know the dependency tree in advance and
+cannot sort the queue of things to install in a topologically correct
+order. It resolves perfectly well B<if> all modules declare the
+prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
+the C<requires> stanza of Module::Build. For bundles which fail and
+you need to install often, it is recommended to sort the Bundle
+definition file manually.
+
+=item 8)
+
+In our intranet, we have many modules for internal use. How
+can I integrate these modules with CPAN.pm but without uploading
+the modules to CPAN?
+
+Have a look at the CPAN::Site module.
+
+=item 9)
+
+When I run CPAN's shell, I get an error message about things in my
+C</etc/inputrc> (or C<~/.inputrc>) file.
+
+These are readline issues and can only be fixed by studying readline
+configuration on your architecture and adjusting the referenced file
+accordingly. Please make a backup of the C</etc/inputrc> or C<~/.inputrc>
+and edit them. Quite often harmless changes like uppercasing or
+lowercasing some arguments solves the problem.
+
+=item 10)
+
+Some authors have strange characters in their names.
+
+Internally CPAN.pm uses the UTF-8 charset. If your terminal is
+expecting ISO-8859-1 charset, a converter can be activated by setting
+term_is_latin to a true value in your config file. One way of doing so
+would be
+
+ cpan> o conf term_is_latin 1
+
+If other charset support is needed, please file a bugreport against
+CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
+the support or maybe UTF-8 terminals become widely available.
+
+Note: this config variable is deprecated and will be removed in a
+future version of CPAN.pm. It will be replaced with the conventions
+around the family of $LANG and $LC_* environment variables.
+
+=item 11)
+
+When an install fails for some reason and then I correct the error
+condition and retry, CPAN.pm refuses to install the module, saying
+C<Already tried without success>.
+
+Use the force pragma like so
+
+ force install Foo::Bar
+
+Or you can use
+
+ look Foo::Bar
+
+and then C<make install> directly in the subshell.
+
+=item 12)
+
+How do I install a "DEVELOPER RELEASE" of a module?
+
+By default, CPAN will install the latest non-developer release of a
+module. If you want to install a dev release, you have to specify the
+partial path starting with the author id to the tarball you wish to
+install, like so:
+
+ cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
+
+Note that you can use the C<ls> command to get this path listed.
+
+=item 13)
+
+How do I install a module and all its dependencies from the commandline,
+without being prompted for anything, despite my CPAN configuration
+(or lack thereof)?
+
+CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
+if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
+asked any questions at all (assuming the modules you are installing are
+nice about obeying that variable as well):
+
+ % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
+
+=item 14)
+
+How do I create a Module::Build based Build.PL derived from an
+ExtUtils::MakeMaker focused Makefile.PL?
+
+http://search.cpan.org/dist/Module-Build-Convert/
+
+=item 15)
+
+I'm frequently irritated with the CPAN shell's inability to help me
+select a good mirror.
+
+The urllist config parameter is yours. You can add and remove sites at
+will. You should find out which sites have the best uptodateness,
+bandwidth, reliability, etc. and are topologically close to you. Some
+people prefer fast downloads, others uptodateness, others reliability.
+You decide which to try in which order.
+
+Henk P. Penning maintains a site that collects data about CPAN sites:
+
+ http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
+
+Also, feel free to play with experimental features. Run
+
+ o conf init randomize_urllist ftpstats_period ftpstats_size
+
+and choose your favorite parameters. After a few downloads running the
+C<hosts> command will probably assist you in choosing the best mirror
+sites.
+
+=item 16)
+
+Why do I get asked the same questions every time I start the shell?
+
+You can make your configuration changes permanent by calling the
+command C<o conf commit>. Alternatively set the C<auto_commit>
+variable to true by running C<o conf init auto_commit> and answering
+the following question with yes.
+
+=item 17)
+
+Older versions of CPAN.pm had the original root directory of all
+tarballs in the build directory. Now there are always random
+characters appended to these directory names. Why was this done?
+
+The random characters are provided by File::Temp and ensure that each
+module's individual build directory is unique. This makes running
+CPAN.pm in concurrent processes simultaneously safe.
+
+=item 18)
+
+Speaking of the build directory. Do I have to clean it up myself?
+
+You have the choice to set the config variable C<scan_cache> to
+C<never>. Then you must clean it up yourself. The other possible
+value, C<atstart> only cleans up the build directory when you start
+the CPAN shell. If you never start up the CPAN shell, you probably
+also have to clean up the build directory yourself.
+
+=back
+
+=head1 COMPATIBILITY
+
+=head2 OLD PERL VERSIONS
+
+CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
+newer versions. It is getting more and more difficult to get the
+minimal prerequisites working on older perls. It is close to
+impossible to get the whole Bundle::CPAN working there. If you're in
+the position to have only these old versions, be advised that CPAN is
+designed to work fine without the Bundle::CPAN installed.
+
+To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
+compatible with ancient perls and that File::Temp is listed as a
+prerequisite but CPAN has reasonable workarounds if it is missing.
+
+=head2 CPANPLUS
+
+This module and its competitor, the CPANPLUS module, are both much
+cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
+more modular, but it was never intended to be compatible with CPAN.pm.
+
+=head1 SECURITY ADVICE
+
+This software enables you to upgrade software on your computer and so
+is inherently dangerous because the newly installed software may
+contain bugs and may alter the way your computer works or even make it
+unusable. Please consider backing up your data before every upgrade.
+
+=head1 BUGS
+
+Please report bugs via L<http://rt.cpan.org/>
+
+Before submitting a bug, please make sure that the traditional method
+of building a Perl module package from a shell by following the
+installation instructions of that package still works in your
+environment.
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk@cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=head1 TRANSLATIONS
+
+Kawai,Takanori provides a Japanese translation of a very old version
+of this manpage at
+L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
+
+=head1 SEE ALSO
+
+Many people enter the CPAN shell by running the L<cpan> utility
+program which is installed in the same directory as perl itself. So if
+you have this directory in your PATH variable (or some equivalent in
+your operating system) then typing C<cpan> in a console window will
+work for you as well. Above that the utility provides several
+commandline shortcuts.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS.pm b/Master/tlpkg/tlperl/lib/CPANPLUS.pm
new file mode 100644
index 00000000000..b61771b242c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS.pm
@@ -0,0 +1,271 @@
+package CPANPLUS;
+
+use strict;
+use Carp;
+
+use CPANPLUS::Error;
+use CPANPLUS::Backend;
+
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+BEGIN {
+ use Exporter ();
+ use vars qw( @EXPORT @ISA $VERSION );
+ @EXPORT = qw( shell fetch get install );
+ @ISA = qw( Exporter );
+ $VERSION = "0.90"; #have to hardcode or cpan.org gets unhappy
+}
+
+### purely for backward compatibility, so we can call it from the commandline:
+### perl -MCPANPLUS -e 'install Net::SMTP'
+sub install {
+ my $cpan = CPANPLUS::Backend->new;
+ my $mod = shift or (
+ error(loc("No module specified!")), return
+ );
+
+ if ( ref $mod ) {
+ error( loc( "You passed an object. Use %1 for OO style interaction",
+ 'CPANPLUS::Backend' ));
+ return;
+
+ } else {
+ my $obj = $cpan->module_tree($mod) or (
+ error(loc("No such module '%1'", $mod)),
+ return
+ );
+
+ my $ok = $obj->install;
+
+ $ok
+ ? msg(loc("Installing of %1 successful", $mod),1)
+ : msg(loc("Installing of %1 failed", $mod),1);
+
+ return $ok;
+ }
+}
+
+### simply downloads a module and stores it
+sub fetch {
+ my $cpan = CPANPLUS::Backend->new;
+
+ my $mod = shift or (
+ error(loc("No module specified!")), return
+ );
+
+ if ( ref $mod ) {
+ error( loc( "You passed an object. Use %1 for OO style interaction",
+ 'CPANPLUS::Backend' ));
+ return;
+
+ } else {
+ my $obj = $cpan->module_tree($mod) or (
+ error(loc("No such module '%1'", $mod)),
+ return
+ );
+
+ my $ok = $obj->fetch( fetchdir => '.' );
+
+ $ok
+ ? msg(loc("Fetching of %1 successful", $mod),1)
+ : msg(loc("Fetching of %1 failed", $mod),1);
+
+ return $ok;
+ }
+}
+
+### alias to fetch() due to compatibility with cpan.pm ###
+sub get { fetch(@_) }
+
+
+### purely for backwards compatibility, so we can call it from the commandline:
+### perl -MCPANPLUS -e 'shell'
+sub shell {
+ my $option = shift;
+
+ ### since the user can specify the type of shell they wish to start
+ ### when they call the shell() function, we have to eval the usage
+ ### of CPANPLUS::Shell so we can set up all the checks properly
+ eval { require CPANPLUS::Shell; CPANPLUS::Shell->import($option) };
+ die $@ if $@;
+
+ my $cpan = CPANPLUS::Shell->new();
+
+ $cpan->shell();
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+CPANPLUS - API & CLI access to the CPAN mirrors
+
+=head1 SYNOPSIS
+
+ ### standard invocation from the command line
+ $ cpanp
+ $ cpanp -i Some::Module
+
+ $ perl -MCPANPLUS -eshell
+ $ perl -MCPANPLUS -e'fetch Some::Module'
+
+
+=head1 DESCRIPTION
+
+The C<CPANPLUS> library is an API to the C<CPAN> mirrors and a
+collection of interactive shells, commandline programs, etc,
+that use this API.
+
+=head1 GUIDE TO DOCUMENTATION
+
+=head2 GENERAL USAGE
+
+This is the document you are currently reading. It describes
+basic usage and background information. Its main purpose is to
+assist the user who wants to learn how to invoke CPANPLUS
+and install modules from the commandline and to point you
+to more indepth reading if required.
+
+=head2 API REFERENCE
+
+The C<CPANPLUS> API is meant to let you programmatically
+interact with the C<CPAN> mirrors. The documentation in
+L<CPANPLUS::Backend> shows you how to create an object
+capable of interacting with those mirrors, letting you
+create & retrieve module objects.
+L<CPANPLUS::Module> shows you how you can use these module
+objects to perform actions like installing and testing.
+
+The default shell, documented in L<CPANPLUS::Shell::Default>
+is also scriptable. You can use its API to dispatch calls
+from your script to the CPANPLUS Shell.
+
+=cut
+
+=head1 COMMANDLINE TOOLS
+
+=head2 STARTING AN INTERACTIVE SHELL
+
+You can start an interactive shell by running either of
+the two following commands:
+
+ $ cpanp
+
+ $ perl -MCPANPLUS -eshell
+
+All commans available are listed in the interactive shells
+help menu. See C<cpanp -h> or L<CPANPLUS::Shell::Default>
+for instructions on using the default shell.
+
+=head2 CHOOSE A SHELL
+
+By running C<cpanp> without arguments, you will start up
+the shell specified in your config, which defaults to
+L<CPANPLUS::Shell::Default>. There are more shells available.
+C<CPANPLUS> itself ships with an emulation shell called
+L<CPANPLUS::Shell::Classic> that looks and feels just like
+the old C<CPAN.pm> shell.
+
+You can start this shell by typing:
+
+ $ perl -MCPANPLUS -e'shell Classic'
+
+Even more shells may be available from C<CPAN>.
+
+Note that if you have changed your default shell in your
+configuration, that shell will be used instead. If for
+some reason there was an error with your specified shell,
+you will be given the default shell.
+
+=head2 BUILDING PACKAGES
+
+C<cpan2dist> is a commandline tool to convert any distribution
+from C<CPAN> into a package in the format of your choice, like
+for example C<.deb> or C<FreeBSD ports>.
+
+See C<cpan2dist -h> for details.
+
+
+=head1 FUNCTIONS
+
+For quick access to common commands, you may use this module,
+C<CPANPLUS> rather than the full programmatic API situated in
+C<CPANPLUS::Backend>. This module offers the following functions:
+
+=head2 $bool = install( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+This function requires the full name of the module, which is case
+sensitive. The module name can also be provided as a fully
+qualified file name, beginning with a I</>, relative to
+the /authors/id directory on a CPAN mirror.
+
+It will download, extract and install the module.
+
+=head2 $where = fetch( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+Like install, fetch needs the full name of a module or the fully
+qualified file name, and is case sensitive.
+
+It will download the specified module to the current directory.
+
+=head2 $where = get( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+Get is provided as an alias for fetch for compatibility with
+CPAN.pm.
+
+=head2 shell()
+
+Shell starts the default CPAN shell. You can also start the shell
+by using the C<cpanp> command, which will be installed in your
+perl bin.
+
+=head1 FAQ
+
+For frequently asked questions and answers, please consult the
+C<CPANPLUS::FAQ> manual.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS::Module>, L<cpanp>, L<cpan2dist>
+
+=head1 CONTACT INFORMATION
+
+=over 4
+
+=item * Bug reporting:
+I<bug-cpanplus@rt.cpan.org>
+
+=item * Questions & suggestions:
+I<cpanplus-devel@lists.sourceforge.net>
+
+=back
+
+
+=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/Carp.pm b/Master/tlpkg/tlperl/lib/Carp.pm
new file mode 100644
index 00000000000..b2948ea7664
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Carp.pm
@@ -0,0 +1,538 @@
+package Carp;
+
+our $VERSION = '1.17';
+
+our $MaxEvalLen = 0;
+our $Verbose = 0;
+our $CarpLevel = 0;
+our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
+our $MaxArgNums = 8; # How many arguments to print. 0 = all.
+
+require Exporter;
+our @ISA = ('Exporter');
+our @EXPORT = qw(confess croak carp);
+our @EXPORT_OK = qw(cluck verbose longmess shortmess);
+our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
+
+# The members of %Internal are packages that are internal to perl.
+# Carp will not report errors from within these packages if it
+# can. The members of %CarpInternal are internal to Perl's warning
+# system. Carp will not report errors from within these packages
+# either, and will not report calls *to* these packages for carp and
+# croak. They replace $CarpLevel, which is deprecated. The
+# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
+# text and function arguments should be formatted when printed.
+
+# disable these by default, so they can live w/o require Carp
+$CarpInternal{Carp}++;
+$CarpInternal{warnings}++;
+$Internal{Exporter}++;
+$Internal{'Exporter::Heavy'}++;
+
+# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
+# then the following method will be called by the Exporter which knows
+# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
+# 'verbose'.
+
+sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
+
+sub longmess {
+ # Icky backwards compatibility wrapper. :-(
+ #
+ # The story is that the original implementation hard-coded the
+ # number of call levels to go back, so calls to longmess were off
+ # by one. Other code began calling longmess and expecting this
+ # behaviour, so the replacement has to emulate that behaviour.
+ my $call_pack = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller();
+ if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
+ return longmess_heavy(@_);
+ }
+ else {
+ local $CarpLevel = $CarpLevel + 1;
+ return longmess_heavy(@_);
+ }
+};
+
+sub shortmess {
+ # Icky backwards compatibility wrapper. :-(
+ local @CARP_NOT = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller();
+ shortmess_heavy(@_);
+};
+
+sub croak { die shortmess @_ }
+sub confess { die longmess @_ }
+sub carp { warn shortmess @_ }
+sub cluck { warn longmess @_ }
+
+sub caller_info {
+ my $i = shift(@_) + 1;
+ my %call_info;
+ {
+ package DB;
+ @args = \$i; # A sentinal, which no-one else has the address of
+ @call_info{
+ qw(pack file line sub has_args wantarray evaltext is_require)
+ } = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
+ }
+
+ unless (defined $call_info{pack}) {
+ return ();
+ }
+
+ my $sub_name = Carp::get_subname(\%call_info);
+ if ($call_info{has_args}) {
+ my @args;
+ if (@DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i) {
+ @DB::args = (); # Don't let anyone see the address of $i
+ @args = "** Incomplete caller override detected; \@DB::args were not set **";
+ } else {
+ @args = map {Carp::format_arg($_)} @DB::args;
+ }
+ if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
+ $#args = $MaxArgNums;
+ push @args, '...';
+ }
+ # Push the args onto the subroutine
+ $sub_name .= '(' . join (', ', @args) . ')';
+ }
+ $call_info{sub_name} = $sub_name;
+ return wantarray() ? %call_info : \%call_info;
+}
+
+# Transform an argument to a function into a string.
+sub format_arg {
+ my $arg = shift;
+ if (ref($arg)) {
+ $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
+ }
+ if (defined($arg)) {
+ $arg =~ s/'/\\'/g;
+ $arg = str_len_trim($arg, $MaxArgLen);
+
+ # Quote it?
+ $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
+ } else {
+ $arg = 'undef';
+ }
+
+ # The following handling of "control chars" is direct from
+ # the original code - it is broken on Unicode though.
+ # Suggestions?
+ utf8::is_utf8($arg)
+ or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+ return $arg;
+}
+
+# Takes an inheritance cache and a package and returns
+# an anon hash of known inheritances and anon array of
+# inheritances which consequences have not been figured
+# for.
+sub get_status {
+ my $cache = shift;
+ my $pkg = shift;
+ $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
+ return @{$cache->{$pkg}};
+}
+
+# Takes the info from caller() and figures out the name of
+# the sub/require/eval
+sub get_subname {
+ my $info = shift;
+ if (defined($info->{evaltext})) {
+ my $eval = $info->{evaltext};
+ if ($info->{is_require}) {
+ return "require $eval";
+ }
+ else {
+ $eval =~ s/([\\\'])/\\$1/g;
+ return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
+ }
+ }
+
+ return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
+}
+
+# Figures out what call (from the point of view of the caller)
+# the long error backtrace should start at.
+sub long_error_loc {
+ my $i;
+ my $lvl = $CarpLevel;
+ {
+ ++$i;
+ my $pkg = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
+ unless(defined($pkg)) {
+ # This *shouldn't* happen.
+ if (%Internal) {
+ local %Internal;
+ $i = long_error_loc();
+ last;
+ }
+ else {
+ # OK, now I am irritated.
+ return 2;
+ }
+ }
+ redo if $CarpInternal{$pkg};
+ redo unless 0 > --$lvl;
+ redo if $Internal{$pkg};
+ }
+ return $i - 1;
+}
+
+
+sub longmess_heavy {
+ return @_ if ref($_[0]); # don't break references as exceptions
+ my $i = long_error_loc();
+ return ret_backtrace($i, @_);
+}
+
+# Returns a full stack backtrace starting from where it is
+# told.
+sub ret_backtrace {
+ my ($i, @error) = @_;
+ my $mess;
+ my $err = join '', @error;
+ $i++;
+
+ my $tid_msg = '';
+ if (defined &threads::tid) {
+ my $tid = threads->tid;
+ $tid_msg = " thread $tid" if $tid;
+ }
+
+ my %i = caller_info($i);
+ $mess = "$err at $i{file} line $i{line}$tid_msg\n";
+
+ while (my %i = caller_info(++$i)) {
+ $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
+ }
+
+ return $mess;
+}
+
+sub ret_summary {
+ my ($i, @error) = @_;
+ my $err = join '', @error;
+ $i++;
+
+ my $tid_msg = '';
+ if (defined &threads::tid) {
+ my $tid = threads->tid;
+ $tid_msg = " thread $tid" if $tid;
+ }
+
+ my %i = caller_info($i);
+ return "$err at $i{file} line $i{line}$tid_msg\n";
+}
+
+
+sub short_error_loc {
+ # You have to create your (hash)ref out here, rather than defaulting it
+ # inside trusts *on a lexical*, as you want it to persist across calls.
+ # (You can default it on $_[2], but that gets messy)
+ my $cache = {};
+ my $i = 1;
+ my $lvl = $CarpLevel;
+ {
+
+ my $called = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
+ $i++;
+ my $caller = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
+
+ return 0 unless defined($caller); # What happened?
+ redo if $Internal{$caller};
+ redo if $CarpInternal{$caller};
+ redo if $CarpInternal{$called};
+ redo if trusts($called, $caller, $cache);
+ redo if trusts($caller, $called, $cache);
+ redo unless 0 > --$lvl;
+ }
+ return $i - 1;
+}
+
+
+sub shortmess_heavy {
+ return longmess_heavy(@_) if $Verbose;
+ return @_ if ref($_[0]); # don't break references as exceptions
+ my $i = short_error_loc();
+ if ($i) {
+ ret_summary($i, @_);
+ }
+ else {
+ longmess_heavy(@_);
+ }
+}
+
+# If a string is too long, trims it with ...
+sub str_len_trim {
+ my $str = shift;
+ my $max = shift || 0;
+ if (2 < $max and $max < length($str)) {
+ substr($str, $max - 3) = '...';
+ }
+ return $str;
+}
+
+# Takes two packages and an optional cache. Says whether the
+# first inherits from the second.
+#
+# Recursive versions of this have to work to avoid certain
+# possible endless loops, and when following long chains of
+# inheritance are less efficient.
+sub trusts {
+ my $child = shift;
+ my $parent = shift;
+ my $cache = shift;
+ my ($known, $partial) = get_status($cache, $child);
+ # Figure out consequences until we have an answer
+ while (@$partial and not exists $known->{$parent}) {
+ my $anc = shift @$partial;
+ next if exists $known->{$anc};
+ $known->{$anc}++;
+ my ($anc_knows, $anc_partial) = get_status($cache, $anc);
+ my @found = keys %$anc_knows;
+ @$known{@found} = ();
+ push @$partial, @$anc_partial;
+ }
+ return exists $known->{$parent};
+}
+
+# Takes a package and gives a list of those trusted directly
+sub trusts_directly {
+ my $class = shift;
+ no strict 'refs';
+ no warnings 'once';
+ return @{"$class\::CARP_NOT"}
+ ? @{"$class\::CARP_NOT"}
+ : @{"$class\::ISA"};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+carp - warn of errors (from perspective of caller)
+
+cluck - warn of errors with stack backtrace
+ (not exported by default)
+
+croak - die of errors (from perspective of caller)
+
+confess - die of errors with stack backtrace
+
+=head1 SYNOPSIS
+
+ use Carp;
+ croak "We're outta here!";
+
+ use Carp qw(cluck);
+ cluck "This is how we got here!";
+
+=head1 DESCRIPTION
+
+The Carp routines are useful in your own modules because
+they act like die() or warn(), but with a message which is more
+likely to be useful to a user of your module. In the case of
+cluck, confess, and longmess that context is a summary of every
+call in the call-stack. For a shorter message you can use C<carp>
+or C<croak> which report the error as being from where your module
+was called. There is no guarantee that that is where the error
+was, but it is a good educated guess.
+
+You can also alter the way the output and logic of C<Carp> works, by
+changing some global variables in the C<Carp> namespace. See the
+section on C<GLOBAL VARIABLES> below.
+
+Here is a more complete description of how C<carp> and C<croak> work.
+What they do is search the call-stack for a function call stack where
+they have not been told that there shouldn't be an error. If every
+call is marked safe, they give up and give a full stack backtrace
+instead. In other words they presume that the first likely looking
+potential suspect is guilty. Their rules for telling whether
+a call shouldn't generate errors work as follows:
+
+=over 4
+
+=item 1.
+
+Any call from a package to itself is safe.
+
+=item 2.
+
+Packages claim that there won't be errors on calls to or from
+packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
+(if that array is empty) C<@ISA>. The ability to override what
+@ISA says is new in 5.8.
+
+=item 3.
+
+The trust in item 2 is transitive. If A trusts B, and B
+trusts C, then A trusts C. So if you do not override C<@ISA>
+with C<@CARP_NOT>, then this trust relationship is identical to,
+"inherits from".
+
+=item 4.
+
+Any call from an internal Perl module is safe. (Nothing keeps
+user modules from marking themselves as internal to Perl, but
+this practice is discouraged.)
+
+=item 5.
+
+Any call to Perl's warning system (eg Carp itself) is safe.
+(This rule is what keeps it from reporting the error at the
+point where you call C<carp> or C<croak>.)
+
+=item 6.
+
+C<$Carp::CarpLevel> can be set to skip a fixed number of additional
+call levels. Using this is not recommended because it is very
+difficult to get it to behave correctly.
+
+=back
+
+=head2 Forcing a Stack Trace
+
+As a debugging aid, you can force Carp to treat a croak as a confess
+and a carp as a cluck across I<all> modules. In other words, force a
+detailed stack trace to be given. This can be very helpful when trying
+to understand why, or from where, a warning or error is being generated.
+
+This feature is enabled by 'importing' the non-existent symbol
+'verbose'. You would typically enable it by saying
+
+ perl -MCarp=verbose script.pl
+
+or by including the string C<-MCarp=verbose> in the PERL5OPT
+environment variable.
+
+Alternately, you can set the global variable C<$Carp::Verbose> to true.
+See the C<GLOBAL VARIABLES> section below.
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Carp::MaxEvalLen
+
+This variable determines how many characters of a string-eval are to
+be shown in the output. Use a value of C<0> to show all text.
+
+Defaults to C<0>.
+
+=head2 $Carp::MaxArgLen
+
+This variable determines how many characters of each argument to a
+function to print. Use a value of C<0> to show the full length of the
+argument.
+
+Defaults to C<64>.
+
+=head2 $Carp::MaxArgNums
+
+This variable determines how many arguments to each function to show.
+Use a value of C<0> to show all arguments to a function call.
+
+Defaults to C<8>.
+
+=head2 $Carp::Verbose
+
+This variable makes C<carp> and C<croak> generate stack backtraces
+just like C<cluck> and C<confess>. This is how C<use Carp 'verbose'>
+is implemented internally.
+
+Defaults to C<0>.
+
+=head2 @CARP_NOT
+
+This variable, I<in your package>, says which packages are I<not> to be
+considered as the location of an error. The C<carp()> and C<cluck()>
+functions will skip over callers when reporting where an error occurred.
+
+NB: This variable must be in the package's symbol table, thus:
+
+ # These work
+ our @CARP_NOT; # file scope
+ use vars qw(@CARP_NOT); # package scope
+ @My::Package::CARP_NOT = ... ; # explicit package variable
+
+ # These don't work
+ sub xyz { ... @CARP_NOT = ... } # w/o declarations above
+ my @CARP_NOT; # even at top-level
+
+Example of use:
+
+ package My::Carping::Package;
+ use Carp;
+ our @CARP_NOT;
+ sub bar { .... or _error('Wrong input') }
+ sub _error {
+ # temporary control of where'ness, __PACKAGE__ is implicit
+ local @CARP_NOT = qw(My::Friendly::Caller);
+ carp(@_)
+ }
+
+This would make C<Carp> report the error as coming from a caller not
+in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
+
+Also read the L</DESCRIPTION> section above, about how C<Carp> decides
+where the error is reported from.
+
+Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
+
+Overrides C<Carp>'s use of C<@ISA>.
+
+=head2 %Carp::Internal
+
+This says what packages are internal to Perl. C<Carp> will never
+report an error as being from a line in a package that is internal to
+Perl. For example:
+
+ $Carp::Internal{ (__PACKAGE__) }++;
+ # time passes...
+ sub foo { ... or confess("whatever") };
+
+would give a full stack backtrace starting from the first caller
+outside of __PACKAGE__. (Unless that package was also internal to
+Perl.)
+
+=head2 %Carp::CarpInternal
+
+This says which packages are internal to Perl's warning system. For
+generating a full stack backtrace this is the same as being internal
+to Perl, the stack backtrace will not start inside packages that are
+listed in C<%Carp::CarpInternal>. But it is slightly different for
+the summary message generated by C<carp> or C<croak>. There errors
+will not be reported on any lines that are calling packages in
+C<%Carp::CarpInternal>.
+
+For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
+Therefore the full stack backtrace from C<confess> will not start
+inside of C<Carp>, and the short message from calling C<croak> is
+not placed on the line where C<croak> was called.
+
+=head2 $Carp::CarpLevel
+
+This variable determines how many additional call frames are to be
+skipped that would not otherwise be when reporting where an error
+occurred on a call to one of C<Carp>'s functions. It is fairly easy
+to count these call frames on calls that generate a full stack
+backtrace. However it is much harder to do this accounting for calls
+that generate a short message. Usually people skip too many call
+frames. If they are lucky they skip enough that C<Carp> goes all of
+the way through the call stack, realizes that something is wrong, and
+then generates a full stack backtrace. If they are unlucky then the
+error is reported from somewhere misleading very high in the call
+stack.
+
+Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
+C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
+
+Defaults to C<0>.
+
+=head1 BUGS
+
+The Carp routines don't handle exception objects currently.
+If called with a first argument that is a reference, they simply
+call die() or warn(), as appropriate.
+
diff --git a/Master/tlpkg/tlperl/lib/Config.pm b/Master/tlpkg/tlperl/lib/Config.pm
new file mode 100644
index 00000000000..0720bac59ba
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config.pm
@@ -0,0 +1,103 @@
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+# for a description of the variables, please have a look at the
+# Glossary file, as written in the Porting folder, or use the url:
+# http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
+
+package Config;
+use strict;
+# use warnings; Pulls in Carp
+# use vars pulls in Carp
+@Config::EXPORT = qw(%Config);
+@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);
+
+# Need to stub all the functions to make code such as print Config::config_sh
+# keep working
+
+sub myconfig;
+sub config_sh;
+sub config_vars;
+sub config_re;
+
+my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);
+
+our %Config;
+
+# Define our own import method to avoid pulling in the full Exporter:
+sub import {
+ my $pkg = shift;
+ @_ = @Config::EXPORT unless @_;
+
+ my @funcs = grep $_ ne '%Config', @_;
+ my $export_Config = @funcs < @_ ? 1 : 0;
+
+ no strict 'refs';
+ my $callpkg = caller(0);
+ foreach my $func (@funcs) {
+ die sprintf qq{"%s" is not exported by the %s module\n},
+ $func, __PACKAGE__ unless $Export_Cache{$func};
+ *{$callpkg.'::'.$func} = \&{$func};
+ }
+
+ *{"$callpkg\::Config"} = \%Config if $export_Config;
+ return;
+}
+
+die "Perl lib version (5.12.3) doesn't match executable version ($])"
+ unless $^V;
+
+$^V eq 5.12.3
+ or die "Perl lib version (5.12.3) doesn't match executable version (" .
+ sprintf("v%vd",$^V) . ")";
+
+
+sub FETCH {
+ my($self, $key) = @_;
+
+ # check for cached value (which may be undef so we use exists not defined)
+ return $self->{$key} if exists $self->{$key};
+
+ return $self->fetch_string($key);
+}
+sub TIEHASH {
+ bless $_[1], $_[0];
+}
+
+sub DESTROY { }
+
+sub AUTOLOAD {
+ require 'Config_heavy.pl';
+ goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
+ die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
+}
+
+my $rootdir = __FILE__;
+$rootdir =~ s![\\/][^\\/]*[\\/][^\\/]*$!!;
+$rootdir =~ s!/!\\!g;
+
+# tie returns the object, so the value returned to require will be true.
+tie %Config, 'Config', {
+ archlibexp => "$rootdir\\lib",
+ archname => 'MSWin32-x86-multi-thread',
+ cc => 'gcc',
+ d_readlink => undef,
+ d_symlink => undef,
+ dlsrc => 'dl_win32.xs',
+ dont_use_nlink => undef,
+ exe_ext => '.exe',
+ inc_version_list => '',
+ intsize => '4',
+ ldlibpthname => '',
+ libpth => 'X:\\mingw32\\lib',
+ osname => 'MSWin32',
+ osvers => '5.1',
+ path_sep => ';',
+ privlibexp => "$rootdir\\lib",
+ scriptdir => "$rootdir\\bin",
+ sitearchexp => "$rootdir\\site\\lib",
+ sitelibexp => "$rootdir\\site\\lib",
+ useithreads => 'define',
+ usevendorprefix => undef,
+ version => '5.12.3',
+};
diff --git a/Master/tlpkg/tlperl/lib/Config.pmold b/Master/tlpkg/tlperl/lib/Config.pmold
new file mode 100644
index 00000000000..05050a768e7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config.pmold
@@ -0,0 +1,99 @@
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+# for a description of the variables, please have a look at the
+# Glossary file, as written in the Porting folder, or use the url:
+# http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
+
+package Config;
+use strict;
+# use warnings; Pulls in Carp
+# use vars pulls in Carp
+@Config::EXPORT = qw(%Config);
+@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);
+
+# Need to stub all the functions to make code such as print Config::config_sh
+# keep working
+
+sub myconfig;
+sub config_sh;
+sub config_vars;
+sub config_re;
+
+my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);
+
+our %Config;
+
+# Define our own import method to avoid pulling in the full Exporter:
+sub import {
+ my $pkg = shift;
+ @_ = @Config::EXPORT unless @_;
+
+ my @funcs = grep $_ ne '%Config', @_;
+ my $export_Config = @funcs < @_ ? 1 : 0;
+
+ no strict 'refs';
+ my $callpkg = caller(0);
+ foreach my $func (@funcs) {
+ die sprintf qq{"%s" is not exported by the %s module\n},
+ $func, __PACKAGE__ unless $Export_Cache{$func};
+ *{$callpkg.'::'.$func} = \&{$func};
+ }
+
+ *{"$callpkg\::Config"} = \%Config if $export_Config;
+ return;
+}
+
+die "Perl lib version (5.12.3) doesn't match executable version ($])"
+ unless $^V;
+
+$^V eq 5.12.3
+ or die "Perl lib version (5.12.3) doesn't match executable version (" .
+ sprintf("v%vd",$^V) . ")";
+
+
+sub FETCH {
+ my($self, $key) = @_;
+
+ # check for cached value (which may be undef so we use exists not defined)
+ return $self->{$key} if exists $self->{$key};
+
+ return $self->fetch_string($key);
+}
+sub TIEHASH {
+ bless $_[1], $_[0];
+}
+
+sub DESTROY { }
+
+sub AUTOLOAD {
+ require 'Config_heavy.pl';
+ goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
+ die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
+}
+
+# tie returns the object, so the value returned to require will be true.
+tie %Config, 'Config', {
+ archlibexp => 'c:\\perl\\lib',
+ archname => 'MSWin32-x86-multi-thread',
+ cc => 'gcc',
+ d_readlink => undef,
+ d_symlink => undef,
+ dlsrc => 'dl_win32.xs',
+ dont_use_nlink => undef,
+ exe_ext => '.exe',
+ inc_version_list => '',
+ intsize => '4',
+ ldlibpthname => '',
+ libpth => 'X:\\mingw32\\lib',
+ osname => 'MSWin32',
+ osvers => '5.1',
+ path_sep => ';',
+ privlibexp => 'c:\\perl\\lib',
+ scriptdir => 'c:\\perl\\bin',
+ sitearchexp => 'c:\\perl\\site\\lib',
+ sitelibexp => 'c:\\perl\\site\\lib',
+ useithreads => 'define',
+ usevendorprefix => undef,
+ version => '5.12.3',
+};
diff --git a/Master/tlpkg/tlperl/lib/Config.pod b/Master/tlpkg/tlperl/lib/Config.pod
new file mode 100644
index 00000000000..baca2658073
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config.pod
@@ -0,0 +1,8880 @@
+=head1 NAME
+
+Config - access Perl configuration information
+
+=head1 SYNOPSIS
+
+ use Config;
+ if ($Config{usethreads}) {
+ print "has thread support\n"
+ }
+
+ use Config qw(myconfig config_sh config_vars config_re);
+
+ print myconfig();
+
+ print config_sh();
+
+ print config_re();
+
+ config_vars(qw(osname archname));
+
+
+=head1 DESCRIPTION
+
+The Config module contains all the information that was available to
+the C<Configure> program at Perl build time (over 900 values).
+
+Shell variables from the F<config.sh> file (written by Configure) are
+stored in the readonly-variable C<%Config>, indexed by their names.
+
+Values stored in config.sh as 'undef' are returned as undefined
+values. The perl C<exists> function can be used to check if a
+named variable exists.
+
+For a description of the variables, please have a look at the
+Glossary file, as written in the Porting folder, or use the url:
+http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
+
+=over 4
+
+=item myconfig()
+
+Returns a textual summary of the major perl configuration values.
+See also C<-V> in L<perlrun/Switches>.
+
+=item config_sh()
+
+Returns the entire perl configuration information in the form of the
+original config.sh shell variable assignment script.
+
+=item config_re($regex)
+
+Like config_sh() but returns, as a list, only the config entries who's
+names match the $regex.
+
+=item config_vars(@names)
+
+Prints to STDOUT the values of the named configuration variable. Each is
+printed on a separate line in the form:
+
+ name='value';
+
+Names which are unknown are output as C<name='UNKNOWN';>.
+See also C<-V:name> in L<perlrun/Switches>.
+
+=back
+
+=head1 EXAMPLE
+
+Here's a more sophisticated example of using %Config:
+
+ use Config;
+ use strict;
+
+ my %sig_num;
+ my @sig_name;
+ unless($Config{sig_name} && $Config{sig_num}) {
+ die "No sigs?";
+ } else {
+ my @names = split ' ', $Config{sig_name};
+ @sig_num{@names} = split ' ', $Config{sig_num};
+ foreach (@names) {
+ $sig_name[$sig_num{$_}] ||= $_;
+ }
+ }
+
+ print "signal #17 = $sig_name[17]\n";
+ if ($sig_num{ALRM}) {
+ print "SIGALRM is $sig_num{ALRM}\n";
+ }
+
+=head1 WARNING
+
+Because this information is not stored within the perl executable
+itself it is possible (but unlikely) that the information does not
+relate to the actual perl binary which is being used to access it.
+
+The Config module is installed into the architecture and version
+specific library directory ($Config{installarchlib}) and it checks the
+perl version number when loaded.
+
+The values stored in config.sh may be either single-quoted or
+double-quoted. Double-quoted strings are handy for those cases where you
+need to include escape sequences in the strings. To avoid runtime variable
+interpolation, any C<$> and C<@> characters are replaced by C<\$> and
+C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
+or C<\@> in double-quoted strings unless you're willing to deal with the
+consequences. (The slashes will end up escaped and the C<$> or C<@> will
+trigger variable interpolation)
+
+=head1 GLOSSARY
+
+Most C<Config> variables are determined by the C<Configure> script
+on platforms supported by it (which is most UNIX platforms). Some
+platforms have custom-made C<Config> variables, and may thus not have
+some of the variables described below, or may have extraneous variables
+specific to that particular port. See the port specific documentation
+in such cases.
+
+=cut
+
+=head2 _
+
+=over 4
+
+=cut
+
+=item C<_a>
+
+From F<Unix.U>:
+
+This variable defines the extension used for ordinary library files.
+For unix, it is F<.a>. The F<.> is included. Other possible
+values include F<.lib>.
+
+=item C<_exe>
+
+From F<Unix.U>:
+
+This variable defines the extension used for executable files.
+C<DJGPP>, Cygwin and F<OS/2> use F<.exe>. Stratus C<VOS> uses F<.pm>.
+On operating systems which do not require a specific extension
+for executable files, this variable is empty.
+
+=item C<_o>
+
+From F<Unix.U>:
+
+This variable defines the extension used for object files.
+For unix, it is F<.o>. The F<.> is included. Other possible
+values include F<.obj>.
+
+=back
+
+=cut
+
+=head2 a
+
+=over 4
+
+=cut
+
+=item C<afs>
+
+From F<afs.U>:
+
+This variable is set to C<true> if C<AFS> (Andrew File System) is used
+on the system, C<false> otherwise. It is possible to override this
+with a hint value or command line option, but you'd better know
+what you are doing.
+
+=item C<afsroot>
+
+From F<afs.U>:
+
+This variable is by default set to F</afs>. In the unlikely case
+this is not the correct root, it is possible to override this with
+a hint value or command line option. This will be used in subsequent
+tests for AFSness in the configure and test process.
+
+=item C<alignbytes>
+
+From F<alignbytes.U>:
+
+This variable holds the number of bytes required to align a
+double-- or a long double when applicable. Usual values are
+2, 4 and 8. The default is eight, for safety.
+
+=item C<ansi2knr>
+
+From F<ansi2knr.U>:
+
+This variable is set if the user needs to run ansi2knr.
+Currently, this is not supported, so we just abort.
+
+=item C<aphostname>
+
+From F<d_gethname.U>:
+
+This variable contains the command which can be used to compute the
+host name. The command is fully qualified by its absolute path, to make
+it safe when used by a process with super-user privileges.
+
+=item C<api_revision>
+
+From F<patchlevel.U>:
+
+The three variables, api_revision, api_version, and
+api_subversion, specify the version of the oldest perl binary
+compatible with the present perl. In a full version string
+such as F<5.6.1>, api_revision is the C<5>.
+Prior to 5.5.640, the format was a floating point number,
+like 5.00563.
+
+F<perl.c>:incpush() and F<lib/lib.pm> will automatically search in
+F<$sitelib/.>. for older directories back to the limit specified
+by these api_ variables. This is only useful if you have a
+perl library directory tree structured like the default one.
+See C<INSTALL> for how this works. The versioned site_perl
+directory was introduced in 5.005, so that is the lowest
+possible value. The version list appropriate for the current
+system is determined in F<inc_version_list.U>.
+
+C<XXX> To do: Since compatibility can depend on compile time
+options (such as bincompat, longlong, etc.) it should
+(perhaps) be set by Configure, but currently it isn't.
+Currently, we read a hard-wired value from F<patchlevel.h>.
+Perhaps what we ought to do is take the hard-wired value from
+F<patchlevel.h> but then modify it if the current Configure
+options warrant. F<patchlevel.h> then would use an #ifdef guard.
+
+=item C<api_subversion>
+
+From F<patchlevel.U>:
+
+The three variables, api_revision, api_version, and
+api_subversion, specify the version of the oldest perl binary
+compatible with the present perl. In a full version string
+such as F<5.6.1>, api_subversion is the C<1>. See api_revision for
+full details.
+
+=item C<api_version>
+
+From F<patchlevel.U>:
+
+The three variables, api_revision, api_version, and
+api_subversion, specify the version of the oldest perl binary
+compatible with the present perl. In a full version string
+such as F<5.6.1>, api_version is the C<6>. See api_revision for
+full details. As a special case, 5.5.0 is rendered in the
+old-style as 5.005. (In the 5.005_0x maintenance series,
+this was the only versioned directory in $sitelib.)
+
+=item C<api_versionstring>
+
+From F<patchlevel.U>:
+
+This variable combines api_revision, api_version, and
+api_subversion in a format such as 5.6.1 (or 5_6_1) suitable
+for use as a directory name. This is filesystem dependent.
+
+=item C<ar>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the ar program. After Configure runs,
+the value is reset to a plain C<ar> and is not useful.
+
+=item C<archlib>
+
+From F<archlib.U>:
+
+This variable holds the name of the directory in which the user wants
+to put architecture-dependent public library files for $package.
+It is most often a local directory such as F</usr/local/lib>.
+Programs using this variable must be prepared to deal
+with filename expansion.
+
+=item C<archlibexp>
+
+From F<archlib.U>:
+
+This variable is the same as the archlib variable, but is
+filename expanded at configuration time, for convenient use.
+
+=item C<archname>
+
+From F<archname.U>:
+
+This variable is a short name to characterize the current
+architecture. It is used mainly to construct the default archlib.
+
+=item C<archname64>
+
+From F<use64bits.U>:
+
+This variable is used for the 64-bitness part of $archname.
+
+=item C<archobjs>
+
+From F<Unix.U>:
+
+This variable defines any additional objects that must be linked
+in with the program on this architecture. On unix, it is usually
+empty. It is typically used to include emulations of unix calls
+or other facilities. For perl on F<OS/2>, for example, this would
+include F<os2/os2.obj>.
+
+=item C<asctime_r_proto>
+
+From F<d_asctime_r.U>:
+
+This variable encodes the prototype of asctime_r.
+It is zero if d_asctime_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_asctime_r
+is defined.
+
+=item C<awk>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the awk program. After Configure runs,
+the value is reset to a plain C<awk> and is not useful.
+
+=back
+
+=cut
+
+=head2 b
+
+=over 4
+
+=cut
+
+=item C<baserev>
+
+From F<baserev.U>:
+
+The base revision level of this package, from the F<.package> file.
+
+=item C<bash>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<bin>
+
+From F<bin.U>:
+
+This variable holds the name of the directory in which the user wants
+to put publicly executable images for the package in question. It
+is most often a local directory such as F</usr/local/bin>. Programs using
+this variable must be prepared to deal with F<~name> substitution.
+
+=item C<bin_ELF>
+
+From F<dlsrc.U>:
+
+This variable saves the result from configure if generated binaries
+are in C<ELF> format. Only set to defined when the test has actually
+been performed, and the result was positive.
+
+=item C<binexp>
+
+From F<bin.U>:
+
+This is the same as the bin variable, but is filename expanded at
+configuration time, for use in your makefiles.
+
+=item C<bison>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the bison program. After Configure runs,
+the value is reset to a plain C<bison> and is not useful.
+
+=item C<byacc>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the byacc program. After Configure runs,
+the value is reset to a plain C<byacc> and is not useful.
+
+=item C<byteorder>
+
+From F<byteorder.U>:
+
+This variable holds the byte order in a C<UV>. In the following,
+larger digits indicate more significance. The variable byteorder
+is either 4321 on a big-endian machine, or 1234 on a little-endian,
+or 87654321 on a Cray ... or 3412 with weird order !
+
+=back
+
+=cut
+
+=head2 c
+
+=over 4
+
+=cut
+
+=item C<c>
+
+From F<n.U>:
+
+This variable contains the \c string if that is what causes the echo
+command to suppress newline. Otherwise it is null. Correct usage is
+$echo $n "prompt for a question: $c".
+
+=item C<castflags>
+
+From F<d_castneg.U>:
+
+This variable contains a flag that precise difficulties the
+compiler has casting odd floating values to unsigned long:
+0 = ok
+1 = couldn't cast < 0
+2 = couldn't cast >= 0x80000000
+4 = couldn't cast in argument expression list
+
+=item C<cat>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the cat program. After Configure runs,
+the value is reset to a plain C<cat> and is not useful.
+
+=item C<cc>
+
+From F<cc.U>:
+
+This variable holds the name of a command to execute a C compiler which
+can resolve multiple global references that happen to have the same
+name. Usual values are C<cc> and C<gcc>.
+Fervent C<ANSI> compilers may be called C<c89>. C<AIX> has xlc.
+
+=item C<cccdlflags>
+
+From F<dlsrc.U>:
+
+This variable contains any special flags that might need to be
+passed with C<cc -c> to compile modules to be used to create a shared
+library that will be used for dynamic loading. For hpux, this
+should be +z. It is up to the makefile to use it.
+
+=item C<ccdlflags>
+
+From F<dlsrc.U>:
+
+This variable contains any special flags that might need to be
+passed to cc to link with a shared library for dynamic loading.
+It is up to the makefile to use it. For sunos 4.1, it should
+be empty.
+
+=item C<ccflags>
+
+From F<ccflags.U>:
+
+This variable contains any additional C compiler flags desired by
+the user. It is up to the Makefile to use this.
+
+=item C<ccflags_uselargefiles>
+
+From F<uselfs.U>:
+
+This variable contains the compiler flags needed by large file builds
+and added to ccflags by hints files.
+
+=item C<ccname>
+
+From F<Checkcc.U>:
+
+This can set either by hints files or by Configure. If using
+gcc, this is gcc, and if not, usually equal to cc, unimpressive, no?
+Some platforms, however, make good use of this by storing the
+flavor of the C compiler being used here. For example if using
+the Sun WorkShop suite, ccname will be C<workshop>.
+
+=item C<ccsymbols>
+
+From F<Cppsym.U>:
+
+The variable contains the symbols defined by the C compiler alone.
+The symbols defined by cpp or by cc when it calls cpp are not in
+this list, see cppsymbols and cppccsymbols.
+The list is a space-separated list of symbol=value tokens.
+
+=item C<ccversion>
+
+From F<Checkcc.U>:
+
+This can set either by hints files or by Configure. If using
+a (non-gcc) vendor cc, this variable may contain a version for
+the compiler.
+
+=item C<cf_by>
+
+From F<cf_who.U>:
+
+Login name of the person who ran the Configure script and answered the
+questions. This is used to tag both F<config.sh> and F<config_h.SH>.
+
+=item C<cf_email>
+
+From F<cf_email.U>:
+
+Electronic mail address of the person who ran Configure. This can be
+used by units that require the user's e-mail, like F<MailList.U>.
+
+=item C<cf_time>
+
+From F<cf_who.U>:
+
+Holds the output of the C<date> command when the configuration file was
+produced. This is used to tag both F<config.sh> and F<config_h.SH>.
+
+=item C<charbits>
+
+From F<charsize.U>:
+
+This variable contains the value of the C<CHARBITS> symbol, which
+indicates to the C program how many bits there are in a character.
+
+=item C<charsize>
+
+From F<charsize.U>:
+
+This variable contains the value of the C<CHARSIZE> symbol, which
+indicates to the C program how many bytes there are in a character.
+
+=item C<chgrp>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<chmod>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the chmod program. After Configure runs,
+the value is reset to a plain C<chmod> and is not useful.
+
+=item C<chown>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<clocktype>
+
+From F<d_times.U>:
+
+This variable holds the type returned by times(). It can be long,
+or clock_t on C<BSD> sites (in which case <sys/types.h> should be
+included).
+
+=item C<comm>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the comm program. After Configure runs,
+the value is reset to a plain C<comm> and is not useful.
+
+=item C<compress>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<config_arg0>
+
+From F<Options.U>:
+
+This variable contains the string used to invoke the Configure
+command, as reported by the shell in the $0 variable.
+
+=item C<config_argc>
+
+From F<Options.U>:
+
+This variable countains the number of command-line arguments
+passed to Configure, as reported by the shell in the $# variable.
+The individual arguments are stored as variables config_argc1,
+config_argc2, etc.
+
+=item C<config_args>
+
+From F<Options.U>:
+
+This variable contains a single string giving the command-line
+arguments passed to Configure. Spaces within arguments,
+quotes, and escaped characters are not correctly preserved.
+To reconstruct the command line, you must assemble the individual
+command line pieces, given in config_arg[0-9]*.
+
+=item C<contains>
+
+From F<contains.U>:
+
+This variable holds the command to do a grep with a proper return
+status. On most sane systems it is simply C<grep>. On insane systems
+it is a grep followed by a cat followed by a test. This variable
+is primarily for the use of other Configure units.
+
+=item C<cp>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the cp program. After Configure runs,
+the value is reset to a plain C<cp> and is not useful.
+
+=item C<cpio>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<cpp>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the cpp program. After Configure runs,
+the value is reset to a plain C<cpp> and is not useful.
+
+=item C<cpp_stuff>
+
+From F<cpp_stuff.U>:
+
+This variable contains an identification of the concatenation mechanism
+used by the C preprocessor.
+
+=item C<cppccsymbols>
+
+From F<Cppsym.U>:
+
+The variable contains the symbols defined by the C compiler
+when it calls cpp. The symbols defined by the cc alone or cpp
+alone are not in this list, see ccsymbols and cppsymbols.
+The list is a space-separated list of symbol=value tokens.
+
+=item C<cppflags>
+
+From F<ccflags.U>:
+
+This variable holds the flags that will be passed to the C pre-
+processor. It is up to the Makefile to use it.
+
+=item C<cpplast>
+
+From F<cppstdin.U>:
+
+This variable has the same functionality as cppminus, only it applies
+to cpprun and not cppstdin.
+
+=item C<cppminus>
+
+From F<cppstdin.U>:
+
+This variable contains the second part of the string which will invoke
+the C preprocessor on the standard input and produce to standard
+output. This variable will have the value C<-> if cppstdin needs
+a minus to specify standard input, otherwise the value is "".
+
+=item C<cpprun>
+
+From F<cppstdin.U>:
+
+This variable contains the command which will invoke a C preprocessor
+on standard input and put the output to stdout. It is guaranteed not
+to be a wrapper and may be a null string if no preprocessor can be
+made directly available. This preprocessor might be different from the
+one used by the C compiler. Don't forget to append cpplast after the
+preprocessor options.
+
+=item C<cppstdin>
+
+From F<cppstdin.U>:
+
+This variable contains the command which will invoke the C
+preprocessor on standard input and put the output to stdout.
+It is primarily used by other Configure units that ask about
+preprocessor symbols.
+
+=item C<cppsymbols>
+
+From F<Cppsym.U>:
+
+The variable contains the symbols defined by the C preprocessor
+alone. The symbols defined by cc or by cc when it calls cpp are
+not in this list, see ccsymbols and cppccsymbols.
+The list is a space-separated list of symbol=value tokens.
+
+=item C<crypt_r_proto>
+
+From F<d_crypt_r.U>:
+
+This variable encodes the prototype of crypt_r.
+It is zero if d_crypt_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_crypt_r
+is defined.
+
+=item C<cryptlib>
+
+From F<d_crypt.U>:
+
+This variable holds -lcrypt or the path to a F<libcrypt.a> archive if
+the crypt() function is not defined in the standard C library. It is
+up to the Makefile to use this.
+
+=item C<csh>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the csh program. After Configure runs,
+the value is reset to a plain C<csh> and is not useful.
+
+=item C<ctermid_r_proto>
+
+From F<d_ctermid_r.U>:
+
+This variable encodes the prototype of ctermid_r.
+It is zero if d_ctermid_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_ctermid_r
+is defined.
+
+=item C<ctime_r_proto>
+
+From F<d_ctime_r.U>:
+
+This variable encodes the prototype of ctime_r.
+It is zero if d_ctime_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_ctime_r
+is defined.
+
+=back
+
+=cut
+
+=head2 d
+
+=over 4
+
+=cut
+
+=item C<d__fwalk>
+
+From F<d__fwalk.U>:
+
+This variable conditionally defines C<HAS__FWALK> if _fwalk() is
+available to apply a function to all the file handles.
+
+=item C<d_access>
+
+From F<d_access.U>:
+
+This variable conditionally defines C<HAS_ACCESS> if the access() system
+call is available to check for access permissions using real IDs.
+
+=item C<d_accessx>
+
+From F<d_accessx.U>:
+
+This variable conditionally defines the C<HAS_ACCESSX> symbol, which
+indicates to the C program that the accessx() routine is available.
+
+=item C<d_aintl>
+
+From F<d_aintl.U>:
+
+This variable conditionally defines the C<HAS_AINTL> symbol, which
+indicates to the C program that the aintl() routine is available.
+If copysignl is also present we can emulate modfl.
+
+=item C<d_alarm>
+
+From F<d_alarm.U>:
+
+This variable conditionally defines the C<HAS_ALARM> symbol, which
+indicates to the C program that the alarm() routine is available.
+
+=item C<d_archlib>
+
+From F<archlib.U>:
+
+This variable conditionally defines C<ARCHLIB> to hold the pathname
+of architecture-dependent library files for $package. If
+$archlib is the same as $privlib, then this is set to undef.
+
+=item C<d_asctime64>
+
+From F<d_timefuncs64.U>:
+
+This variable conditionally defines the HAS_ASCTIME64 symbol, which
+indicates to the C program that the asctime64 () routine is available.
+
+=item C<d_asctime_r>
+
+From F<d_asctime_r.U>:
+
+This variable conditionally defines the C<HAS_ASCTIME_R> symbol,
+which indicates to the C program that the asctime_r()
+routine is available.
+
+=item C<d_atolf>
+
+From F<atolf.U>:
+
+This variable conditionally defines the C<HAS_ATOLF> symbol, which
+indicates to the C program that the atolf() routine is available.
+
+=item C<d_atoll>
+
+From F<atoll.U>:
+
+This variable conditionally defines the C<HAS_ATOLL> symbol, which
+indicates to the C program that the atoll() routine is available.
+
+=item C<d_attribute_deprecated>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_DEPRECATED>, which
+indicates that C<GCC> can handle the attribute for marking deprecated
+APIs
+
+=item C<d_attribute_format>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_FORMAT>, which
+indicates the C compiler can check for printf-like formats.
+
+=item C<d_attribute_malloc>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_MALLOC>, which
+indicates the C compiler can understand functions as having
+malloc-like semantics.
+
+=item C<d_attribute_nonnull>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_NONNULL>, which
+indicates that the C compiler can know that certain arguments
+must not be C<NULL>, and will check accordingly at compile time.
+
+=item C<d_attribute_noreturn>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_NORETURN>, which
+indicates that the C compiler can know that certain functions
+are guaranteed never to return.
+
+=item C<d_attribute_pure>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_PURE>, which
+indicates that the C compiler can know that certain functions
+are C<pure> functions, meaning that they have no side effects, and
+only rely on function input F<and/or> global data for their results.
+
+=item C<d_attribute_unused>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<HASATTRIBUTE_UNUSED>, which
+indicates that the C compiler can know that certain variables
+and arguments may not always be used, and to not throw warnings
+if they don't get used.
+
+=item C<d_attribute_warn_unused_result>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines
+C<HASATTRIBUTE_WARN_UNUSED_RESULT>, which indicates that the C
+compiler can know that certain functions have a return values
+that must not be ignored, such as malloc() or open().
+
+=item C<d_bcmp>
+
+From F<d_bcmp.U>:
+
+This variable conditionally defines the C<HAS_BCMP> symbol if
+the bcmp() routine is available to compare strings.
+
+=item C<d_bcopy>
+
+From F<d_bcopy.U>:
+
+This variable conditionally defines the C<HAS_BCOPY> symbol if
+the bcopy() routine is available to copy strings.
+
+=item C<d_bsd>
+
+From F<Guess.U>:
+
+This symbol conditionally defines the symbol C<BSD> when running on a
+C<BSD> system.
+
+=item C<d_bsdgetpgrp>
+
+From F<d_getpgrp.U>:
+
+This variable conditionally defines C<USE_BSD_GETPGRP> if
+getpgrp needs one arguments whereas C<USG> one needs none.
+
+=item C<d_bsdsetpgrp>
+
+From F<d_setpgrp.U>:
+
+This variable conditionally defines C<USE_BSD_SETPGRP> if
+setpgrp needs two arguments whereas C<USG> one needs none.
+See also d_setpgid for a C<POSIX> interface.
+
+=item C<d_builtin_choose_expr>
+
+From F<d_builtin.U>:
+
+This conditionally defines C<HAS_BUILTIN_CHOOSE_EXPR>, which
+indicates that the compiler supports __builtin_choose_expr(x,y,z).
+This built-in function is analogous to the C<x?y:z> operator in C,
+except that the expression returned has its type unaltered by
+promotion rules. Also, the built-in function does not evaluate
+the expression that was not chosen.
+
+=item C<d_builtin_expect>
+
+From F<d_builtin.U>:
+
+This conditionally defines C<HAS_BUILTIN_EXPECT>, which indicates
+that the compiler supports __builtin_expect(exp,c). You may use
+__builtin_expect to provide the compiler with branch prediction
+information.
+
+=item C<d_bzero>
+
+From F<d_bzero.U>:
+
+This variable conditionally defines the C<HAS_BZERO> symbol if
+the bzero() routine is available to set memory to 0.
+
+=item C<d_c99_variadic_macros>
+
+From F<d_c99_variadic.U>:
+
+This variable conditionally defines the HAS_C99_VARIADIC_MACROS
+symbol, which indicates to the C program that C99 variadic macros
+are available.
+
+=item C<d_casti32>
+
+From F<d_casti32.U>:
+
+This variable conditionally defines CASTI32, which indicates
+whether the C compiler can cast large floats to 32-bit ints.
+
+=item C<d_castneg>
+
+From F<d_castneg.U>:
+
+This variable conditionally defines C<CASTNEG>, which indicates
+wether the C compiler can cast negative float to unsigned.
+
+=item C<d_charvspr>
+
+From F<d_vprintf.U>:
+
+This variable conditionally defines C<CHARVSPRINTF> if this system
+has vsprintf returning type (char*). The trend seems to be to
+declare it as "int vsprintf()".
+
+=item C<d_chown>
+
+From F<d_chown.U>:
+
+This variable conditionally defines the C<HAS_CHOWN> symbol, which
+indicates to the C program that the chown() routine is available.
+
+=item C<d_chroot>
+
+From F<d_chroot.U>:
+
+This variable conditionally defines the C<HAS_CHROOT> symbol, which
+indicates to the C program that the chroot() routine is available.
+
+=item C<d_chsize>
+
+From F<d_chsize.U>:
+
+This variable conditionally defines the C<CHSIZE> symbol, which
+indicates to the C program that the chsize() routine is available
+to truncate files. You might need a -lx to get this routine.
+
+=item C<d_class>
+
+From F<d_class.U>:
+
+This variable conditionally defines the C<HAS_CLASS> symbol, which
+indicates to the C program that the class() routine is available.
+
+=item C<d_clearenv>
+
+From F<d_clearenv.U>:
+
+This variable conditionally defines the C<HAS_CLEARENV> symbol, which
+indicates to the C program that the clearenv () routine is available.
+
+=item C<d_closedir>
+
+From F<d_closedir.U>:
+
+This variable conditionally defines C<HAS_CLOSEDIR> if closedir() is
+available.
+
+=item C<d_cmsghdr_s>
+
+From F<d_cmsghdr_s.U>:
+
+This variable conditionally defines the C<HAS_STRUCT_CMSGHDR> symbol,
+which indicates that the struct cmsghdr is supported.
+
+=item C<d_const>
+
+From F<d_const.U>:
+
+This variable conditionally defines the C<HASCONST> symbol, which
+indicates to the C program that this C compiler knows about the
+const type.
+
+=item C<d_copysignl>
+
+From F<d_copysignl.U>:
+
+This variable conditionally defines the C<HAS_COPYSIGNL> symbol, which
+indicates to the C program that the copysignl() routine is available.
+If aintl is also present we can emulate modfl.
+
+=item C<d_cplusplus>
+
+From F<d_cplusplus.U>:
+
+This variable conditionally defines the C<USE_CPLUSPLUS> symbol, which
+indicates that a C++ compiler was used to compiled Perl and will be
+used to compile extensions.
+
+=item C<d_crypt>
+
+From F<d_crypt.U>:
+
+This variable conditionally defines the C<CRYPT> symbol, which
+indicates to the C program that the crypt() routine is available
+to encrypt passwords and the like.
+
+=item C<d_crypt_r>
+
+From F<d_crypt_r.U>:
+
+This variable conditionally defines the C<HAS_CRYPT_R> symbol,
+which indicates to the C program that the crypt_r()
+routine is available.
+
+=item C<d_csh>
+
+From F<d_csh.U>:
+
+This variable conditionally defines the C<CSH> symbol, which
+indicates to the C program that the C-shell exists.
+
+=item C<d_ctermid>
+
+From F<d_ctermid.U>:
+
+This variable conditionally defines C<CTERMID> if ctermid() is
+available to generate filename for terminal.
+
+=item C<d_ctermid_r>
+
+From F<d_ctermid_r.U>:
+
+This variable conditionally defines the C<HAS_CTERMID_R> symbol,
+which indicates to the C program that the ctermid_r()
+routine is available.
+
+=item C<d_ctime64>
+
+From F<d_timefuncs64.U>:
+
+This variable conditionally defines the HAS_CTIME64 symbol, which
+indicates to the C program that the ctime64 () routine is available.
+
+=item C<d_ctime_r>
+
+From F<d_ctime_r.U>:
+
+This variable conditionally defines the C<HAS_CTIME_R> symbol,
+which indicates to the C program that the ctime_r()
+routine is available.
+
+=item C<d_cuserid>
+
+From F<d_cuserid.U>:
+
+This variable conditionally defines the C<HAS_CUSERID> symbol, which
+indicates to the C program that the cuserid() routine is available
+to get character login names.
+
+=item C<d_dbl_dig>
+
+From F<d_dbl_dig.U>:
+
+This variable conditionally defines d_dbl_dig if this system's
+header files provide C<DBL_DIG>, which is the number of significant
+digits in a double precision number.
+
+=item C<d_dbminitproto>
+
+From F<d_dbminitproto.U>:
+
+This variable conditionally defines the C<HAS_DBMINIT_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the dbminit() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_difftime>
+
+From F<d_difftime.U>:
+
+This variable conditionally defines the C<HAS_DIFFTIME> symbol, which
+indicates to the C program that the difftime() routine is available.
+
+=item C<d_difftime64>
+
+From F<d_timefuncs64.U>:
+
+This variable conditionally defines the HAS_DIFFTIME64 symbol, which
+indicates to the C program that the difftime64 () routine is available.
+
+=item C<d_dir_dd_fd>
+
+From F<d_dir_dd_fd.U>:
+
+This variable conditionally defines the C<HAS_DIR_DD_FD> symbol, which
+indicates that the C<DIR> directory stream type contains a member
+variable called dd_fd.
+
+=item C<d_dirfd>
+
+From F<d_dirfd.U>:
+
+This variable conditionally defines the C<HAS_DIRFD> constant,
+which indicates to the C program that dirfd() is available
+to return the file descriptor of a directory stream.
+
+=item C<d_dirnamlen>
+
+From F<i_dirent.U>:
+
+This variable conditionally defines C<DIRNAMLEN>, which indicates
+to the C program that the length of directory entry names is
+provided by a d_namelen field.
+
+=item C<d_dlerror>
+
+From F<d_dlerror.U>:
+
+This variable conditionally defines the C<HAS_DLERROR> symbol, which
+indicates to the C program that the dlerror() routine is available.
+
+=item C<d_dlopen>
+
+From F<d_dlopen.U>:
+
+This variable conditionally defines the C<HAS_DLOPEN> symbol, which
+indicates to the C program that the dlopen() routine is available.
+
+=item C<d_dlsymun>
+
+From F<d_dlsymun.U>:
+
+This variable conditionally defines C<DLSYM_NEEDS_UNDERSCORE>, which
+indicates that we need to prepend an underscore to the symbol
+name before calling dlsym().
+
+=item C<d_dosuid>
+
+From F<d_dosuid.U>:
+
+This variable conditionally defines the symbol C<DOSUID>, which
+tells the C program that it should insert setuid emulation code
+on hosts which have setuid #! scripts disabled.
+
+=item C<d_drand48_r>
+
+From F<d_drand48_r.U>:
+
+This variable conditionally defines the HAS_DRAND48_R symbol,
+which indicates to the C program that the drand48_r()
+routine is available.
+
+=item C<d_drand48proto>
+
+From F<d_drand48proto.U>:
+
+This variable conditionally defines the HAS_DRAND48_PROTO symbol,
+which indicates to the C program that the system provides
+a prototype for the drand48() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_dup2>
+
+From F<d_dup2.U>:
+
+This variable conditionally defines HAS_DUP2 if dup2() is
+available to duplicate file descriptors.
+
+=item C<d_eaccess>
+
+From F<d_eaccess.U>:
+
+This variable conditionally defines the C<HAS_EACCESS> symbol, which
+indicates to the C program that the eaccess() routine is available.
+
+=item C<d_endgrent>
+
+From F<d_endgrent.U>:
+
+This variable conditionally defines the C<HAS_ENDGRENT> symbol, which
+indicates to the C program that the endgrent() routine is available
+for sequential access of the group database.
+
+=item C<d_endgrent_r>
+
+From F<d_endgrent_r.U>:
+
+This variable conditionally defines the C<HAS_ENDGRENT_R> symbol,
+which indicates to the C program that the endgrent_r()
+routine is available.
+
+=item C<d_endhent>
+
+From F<d_endhent.U>:
+
+This variable conditionally defines C<HAS_ENDHOSTENT> if endhostent() is
+available to close whatever was being used for host queries.
+
+=item C<d_endhostent_r>
+
+From F<d_endhostent_r.U>:
+
+This variable conditionally defines the C<HAS_ENDHOSTENT_R> symbol,
+which indicates to the C program that the endhostent_r()
+routine is available.
+
+=item C<d_endnent>
+
+From F<d_endnent.U>:
+
+This variable conditionally defines C<HAS_ENDNETENT> if endnetent() is
+available to close whatever was being used for network queries.
+
+=item C<d_endnetent_r>
+
+From F<d_endnetent_r.U>:
+
+This variable conditionally defines the C<HAS_ENDNETENT_R> symbol,
+which indicates to the C program that the endnetent_r()
+routine is available.
+
+=item C<d_endpent>
+
+From F<d_endpent.U>:
+
+This variable conditionally defines C<HAS_ENDPROTOENT> if endprotoent() is
+available to close whatever was being used for protocol queries.
+
+=item C<d_endprotoent_r>
+
+From F<d_endprotoent_r.U>:
+
+This variable conditionally defines the C<HAS_ENDPROTOENT_R> symbol,
+which indicates to the C program that the endprotoent_r()
+routine is available.
+
+=item C<d_endpwent>
+
+From F<d_endpwent.U>:
+
+This variable conditionally defines the C<HAS_ENDPWENT> symbol, which
+indicates to the C program that the endpwent() routine is available
+for sequential access of the passwd database.
+
+=item C<d_endpwent_r>
+
+From F<d_endpwent_r.U>:
+
+This variable conditionally defines the C<HAS_ENDPWENT_R> symbol,
+which indicates to the C program that the endpwent_r()
+routine is available.
+
+=item C<d_endsent>
+
+From F<d_endsent.U>:
+
+This variable conditionally defines C<HAS_ENDSERVENT> if endservent() is
+available to close whatever was being used for service queries.
+
+=item C<d_endservent_r>
+
+From F<d_endservent_r.U>:
+
+This variable conditionally defines the C<HAS_ENDSERVENT_R> symbol,
+which indicates to the C program that the endservent_r()
+routine is available.
+
+=item C<d_eofnblk>
+
+From F<nblock_io.U>:
+
+This variable conditionally defines C<EOF_NONBLOCK> if C<EOF> can be seen
+when reading from a non-blocking I/O source.
+
+=item C<d_eunice>
+
+From F<Guess.U>:
+
+This variable conditionally defines the symbols C<EUNICE> and C<VAX>, which
+alerts the C program that it must deal with ideosyncracies of C<VMS>.
+
+=item C<d_faststdio>
+
+From F<d_faststdio.U>:
+
+This variable conditionally defines the C<HAS_FAST_STDIO> symbol,
+which indicates to the C program that the "fast stdio" is available
+to manipulate the stdio buffers directly.
+
+=item C<d_fchdir>
+
+From F<d_fchdir.U>:
+
+This variable conditionally defines the C<HAS_FCHDIR> symbol, which
+indicates to the C program that the fchdir() routine is available.
+
+=item C<d_fchmod>
+
+From F<d_fchmod.U>:
+
+This variable conditionally defines the C<HAS_FCHMOD> symbol, which
+indicates to the C program that the fchmod() routine is available
+to change mode of opened files.
+
+=item C<d_fchown>
+
+From F<d_fchown.U>:
+
+This variable conditionally defines the C<HAS_FCHOWN> symbol, which
+indicates to the C program that the fchown() routine is available
+to change ownership of opened files.
+
+=item C<d_fcntl>
+
+From F<d_fcntl.U>:
+
+This variable conditionally defines the C<HAS_FCNTL> symbol, and indicates
+whether the fcntl() function exists
+
+=item C<d_fcntl_can_lock>
+
+From F<d_fcntl_can_lock.U>:
+
+This variable conditionally defines the C<FCNTL_CAN_LOCK> symbol
+and indicates whether file locking with fcntl() works.
+
+=item C<d_fd_macros>
+
+From F<d_fd_set.U>:
+
+This variable contains the eventual value of the C<HAS_FD_MACROS> symbol,
+which indicates if your C compiler knows about the macros which
+manipulate an fd_set.
+
+=item C<d_fd_set>
+
+From F<d_fd_set.U>:
+
+This variable contains the eventual value of the C<HAS_FD_SET> symbol,
+which indicates if your C compiler knows about the fd_set typedef.
+
+=item C<d_fds_bits>
+
+From F<d_fd_set.U>:
+
+This variable contains the eventual value of the C<HAS_FDS_BITS> symbol,
+which indicates if your fd_set typedef contains the fds_bits member.
+If you have an fd_set typedef, but the dweebs who installed it did
+a half-fast job and neglected to provide the macros to manipulate
+an fd_set, C<HAS_FDS_BITS> will let us know how to fix the gaffe.
+
+=item C<d_fgetpos>
+
+From F<d_fgetpos.U>:
+
+This variable conditionally defines C<HAS_FGETPOS> if fgetpos() is
+available to get the file position indicator.
+
+=item C<d_finite>
+
+From F<d_finite.U>:
+
+This variable conditionally defines the C<HAS_FINITE> symbol, which
+indicates to the C program that the finite() routine is available.
+
+=item C<d_finitel>
+
+From F<d_finitel.U>:
+
+This variable conditionally defines the C<HAS_FINITEL> symbol, which
+indicates to the C program that the finitel() routine is available.
+
+=item C<d_flexfnam>
+
+From F<d_flexfnam.U>:
+
+This variable conditionally defines the C<FLEXFILENAMES> symbol, which
+indicates that the system supports filenames longer than 14 characters.
+
+=item C<d_flock>
+
+From F<d_flock.U>:
+
+This variable conditionally defines C<HAS_FLOCK> if flock() is
+available to do file locking.
+
+=item C<d_flockproto>
+
+From F<d_flockproto.U>:
+
+This variable conditionally defines the C<HAS_FLOCK_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the flock() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_fork>
+
+From F<d_fork.U>:
+
+This variable conditionally defines the C<HAS_FORK> symbol, which
+indicates to the C program that the fork() routine is available.
+
+=item C<d_fp_class>
+
+From F<d_fp_class.U>:
+
+This variable conditionally defines the C<HAS_FP_CLASS> symbol, which
+indicates to the C program that the fp_class() routine is available.
+
+=item C<d_fpathconf>
+
+From F<d_pathconf.U>:
+
+This variable conditionally defines the C<HAS_FPATHCONF> symbol, which
+indicates to the C program that the pathconf() routine is available
+to determine file-system related limits and options associated
+with a given open file descriptor.
+
+=item C<d_fpclass>
+
+From F<d_fpclass.U>:
+
+This variable conditionally defines the C<HAS_FPCLASS> symbol, which
+indicates to the C program that the fpclass() routine is available.
+
+=item C<d_fpclassify>
+
+From F<d_fpclassify.U>:
+
+This variable conditionally defines the C<HAS_FPCLASSIFY> symbol, which
+indicates to the C program that the fpclassify() routine is available.
+
+=item C<d_fpclassl>
+
+From F<d_fpclassl.U>:
+
+This variable conditionally defines the C<HAS_FPCLASSL> symbol, which
+indicates to the C program that the fpclassl() routine is available.
+
+=item C<d_fpos64_t>
+
+From F<d_fpos64_t.U>:
+
+This symbol will be defined if the C compiler supports fpos64_t.
+
+=item C<d_frexpl>
+
+From F<d_frexpl.U>:
+
+This variable conditionally defines the C<HAS_FREXPL> symbol, which
+indicates to the C program that the frexpl() routine is available.
+
+=item C<d_fs_data_s>
+
+From F<d_fs_data_s.U>:
+
+This variable conditionally defines the C<HAS_STRUCT_FS_DATA> symbol,
+which indicates that the struct fs_data is supported.
+
+=item C<d_fseeko>
+
+From F<d_fseeko.U>:
+
+This variable conditionally defines the C<HAS_FSEEKO> symbol, which
+indicates to the C program that the fseeko() routine is available.
+
+=item C<d_fsetpos>
+
+From F<d_fsetpos.U>:
+
+This variable conditionally defines C<HAS_FSETPOS> if fsetpos() is
+available to set the file position indicator.
+
+=item C<d_fstatfs>
+
+From F<d_fstatfs.U>:
+
+This variable conditionally defines the C<HAS_FSTATFS> symbol, which
+indicates to the C program that the fstatfs() routine is available.
+
+=item C<d_fstatvfs>
+
+From F<d_statvfs.U>:
+
+This variable conditionally defines the C<HAS_FSTATVFS> symbol, which
+indicates to the C program that the fstatvfs() routine is available.
+
+=item C<d_fsync>
+
+From F<d_fsync.U>:
+
+This variable conditionally defines the C<HAS_FSYNC> symbol, which
+indicates to the C program that the fsync() routine is available.
+
+=item C<d_ftello>
+
+From F<d_ftello.U>:
+
+This variable conditionally defines the C<HAS_FTELLO> symbol, which
+indicates to the C program that the ftello() routine is available.
+
+=item C<d_ftime>
+
+From F<d_ftime.U>:
+
+This variable conditionally defines the C<HAS_FTIME> symbol, which indicates
+that the ftime() routine exists. The ftime() routine is basically
+a sub-second accuracy clock.
+
+=item C<d_futimes>
+
+From F<d_futimes.U>:
+
+This variable conditionally defines the C<HAS_FUTIMES> symbol, which
+indicates to the C program that the futimes() routine is available.
+
+=item C<d_Gconvert>
+
+From F<d_gconvert.U>:
+
+This variable holds what Gconvert is defined as to convert
+floating point numbers into strings. By default, Configure
+sets C<this> macro to use the first of gconvert, gcvt, or sprintf
+that pass sprintf-%g-like behaviour tests. If perl is using
+long doubles, the macro uses the first of the following
+functions that pass Configure's tests: qgcvt, sprintf (if
+Configure knows how to make sprintf format long doubles--see
+sPRIgldbl), gconvert, gcvt, and sprintf (casting to double).
+The gconvert_preference and gconvert_ld_preference variables
+can be used to alter Configure's preferences, for doubles and
+long doubles, respectively. If present, they contain a
+space-separated list of one or more of the above function
+names in the order they should be tried.
+
+d_Gconvert may be set to override Configure with a platform-
+specific function. If this function expects a double, a
+different value may need to be set by the F<uselongdouble.cbu>
+call-back unit so that long doubles can be formatted without
+loss of precision.
+
+=item C<d_gdbm_ndbm_h_uses_prototypes>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<NDBM_H_USES_PROTOTYPES> symbol,
+which indicates that the gdbm-F<ndbm.h> include file uses real C<ANSI> C
+prototypes instead of K&R style function declarations. K&R style
+declarations are unsupported in C++, so the include file requires
+special handling when using a C++ compiler and this variable is
+undefined. Consult the different d_*ndbm_h_uses_prototypes variables
+to get the same information for alternative F<ndbm.h> include files.
+
+=item C<d_gdbmndbm_h_uses_prototypes>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<NDBM_H_USES_PROTOTYPES> symbol,
+which indicates that the F<gdbm/ndbm.h> include file uses real C<ANSI> C
+prototypes instead of K&R style function declarations. K&R style
+declarations are unsupported in C++, so the include file requires
+special handling when using a C++ compiler and this variable is
+undefined. Consult the different d_*ndbm_h_uses_prototypes variables
+to get the same information for alternative F<ndbm.h> include files.
+
+=item C<d_getaddrinfo>
+
+From F<d_getaddrinfo.U>:
+
+This variable conditionally defines the C<HAS_GETADDRINFO> symbol,
+which indicates to the C program that the getaddrinfo() function
+is available.
+
+=item C<d_getcwd>
+
+From F<d_getcwd.U>:
+
+This variable conditionally defines the C<HAS_GETCWD> symbol, which
+indicates to the C program that the getcwd() routine is available
+to get the current working directory.
+
+=item C<d_getespwnam>
+
+From F<d_getespwnam.U>:
+
+This variable conditionally defines C<HAS_GETESPWNAM> if getespwnam() is
+available to retrieve enchanced (shadow) password entries by name.
+
+=item C<d_getfsstat>
+
+From F<d_getfsstat.U>:
+
+This variable conditionally defines the C<HAS_GETFSSTAT> symbol, which
+indicates to the C program that the getfsstat() routine is available.
+
+=item C<d_getgrent>
+
+From F<d_getgrent.U>:
+
+This variable conditionally defines the C<HAS_GETGRENT> symbol, which
+indicates to the C program that the getgrent() routine is available
+for sequential access of the group database.
+
+=item C<d_getgrent_r>
+
+From F<d_getgrent_r.U>:
+
+This variable conditionally defines the C<HAS_GETGRENT_R> symbol,
+which indicates to the C program that the getgrent_r()
+routine is available.
+
+=item C<d_getgrgid_r>
+
+From F<d_getgrgid_r.U>:
+
+This variable conditionally defines the C<HAS_GETGRGID_R> symbol,
+which indicates to the C program that the getgrgid_r()
+routine is available.
+
+=item C<d_getgrnam_r>
+
+From F<d_getgrnam_r.U>:
+
+This variable conditionally defines the C<HAS_GETGRNAM_R> symbol,
+which indicates to the C program that the getgrnam_r()
+routine is available.
+
+=item C<d_getgrps>
+
+From F<d_getgrps.U>:
+
+This variable conditionally defines the C<HAS_GETGROUPS> symbol, which
+indicates to the C program that the getgroups() routine is available
+to get the list of process groups.
+
+=item C<d_gethbyaddr>
+
+From F<d_gethbyad.U>:
+
+This variable conditionally defines the C<HAS_GETHOSTBYADDR> symbol, which
+indicates to the C program that the gethostbyaddr() routine is available
+to look up hosts by their C<IP> addresses.
+
+=item C<d_gethbyname>
+
+From F<d_gethbynm.U>:
+
+This variable conditionally defines the C<HAS_GETHOSTBYNAME> symbol, which
+indicates to the C program that the gethostbyname() routine is available
+to look up host names in some data base or other.
+
+=item C<d_gethent>
+
+From F<d_gethent.U>:
+
+This variable conditionally defines C<HAS_GETHOSTENT> if gethostent() is
+available to look up host names in some data base or another.
+
+=item C<d_gethname>
+
+From F<d_gethname.U>:
+
+This variable conditionally defines the C<HAS_GETHOSTNAME> symbol, which
+indicates to the C program that the gethostname() routine may be
+used to derive the host name.
+
+=item C<d_gethostbyaddr_r>
+
+From F<d_gethostbyaddr_r.U>:
+
+This variable conditionally defines the C<HAS_GETHOSTBYADDR_R> symbol,
+which indicates to the C program that the gethostbyaddr_r()
+routine is available.
+
+=item C<d_gethostbyname_r>
+
+From F<d_gethostbyname_r.U>:
+
+This variable conditionally defines the C<HAS_GETHOSTBYNAME_R> symbol,
+which indicates to the C program that the gethostbyname_r()
+routine is available.
+
+=item C<d_gethostent_r>
+
+From F<d_gethostent_r.U>:
+
+This variable conditionally defines the C<HAS_GETHOSTENT_R> symbol,
+which indicates to the C program that the gethostent_r()
+routine is available.
+
+=item C<d_gethostprotos>
+
+From F<d_gethostprotos.U>:
+
+This variable conditionally defines the C<HAS_GETHOST_PROTOS> symbol,
+which indicates to the C program that <netdb.h> supplies
+prototypes for the various gethost*() functions.
+See also F<netdbtype.U> for probing for various netdb types.
+
+=item C<d_getitimer>
+
+From F<d_getitimer.U>:
+
+This variable conditionally defines the C<HAS_GETITIMER> symbol, which
+indicates to the C program that the getitimer() routine is available.
+
+=item C<d_getlogin>
+
+From F<d_getlogin.U>:
+
+This variable conditionally defines the C<HAS_GETLOGIN> symbol, which
+indicates to the C program that the getlogin() routine is available
+to get the login name.
+
+=item C<d_getlogin_r>
+
+From F<d_getlogin_r.U>:
+
+This variable conditionally defines the C<HAS_GETLOGIN_R> symbol,
+which indicates to the C program that the getlogin_r()
+routine is available.
+
+=item C<d_getmnt>
+
+From F<d_getmnt.U>:
+
+This variable conditionally defines the C<HAS_GETMNT> symbol, which
+indicates to the C program that the getmnt() routine is available
+to retrieve one or more mount info blocks by filename.
+
+=item C<d_getmntent>
+
+From F<d_getmntent.U>:
+
+This variable conditionally defines the C<HAS_GETMNTENT> symbol, which
+indicates to the C program that the getmntent() routine is available
+to iterate through mounted files to get their mount info.
+
+=item C<d_getnameinfo>
+
+From F<d_getnameinfo.U>:
+
+This variable conditionally defines the C<HAS_GETNAMEINFO> symbol,
+which indicates to the C program that the getnameinfo() function
+is available.
+
+=item C<d_getnbyaddr>
+
+From F<d_getnbyad.U>:
+
+This variable conditionally defines the C<HAS_GETNETBYADDR> symbol, which
+indicates to the C program that the getnetbyaddr() routine is available
+to look up networks by their C<IP> addresses.
+
+=item C<d_getnbyname>
+
+From F<d_getnbynm.U>:
+
+This variable conditionally defines the C<HAS_GETNETBYNAME> symbol, which
+indicates to the C program that the getnetbyname() routine is available
+to look up networks by their names.
+
+=item C<d_getnent>
+
+From F<d_getnent.U>:
+
+This variable conditionally defines C<HAS_GETNETENT> if getnetent() is
+available to look up network names in some data base or another.
+
+=item C<d_getnetbyaddr_r>
+
+From F<d_getnetbyaddr_r.U>:
+
+This variable conditionally defines the C<HAS_GETNETBYADDR_R> symbol,
+which indicates to the C program that the getnetbyaddr_r()
+routine is available.
+
+=item C<d_getnetbyname_r>
+
+From F<d_getnetbyname_r.U>:
+
+This variable conditionally defines the C<HAS_GETNETBYNAME_R> symbol,
+which indicates to the C program that the getnetbyname_r()
+routine is available.
+
+=item C<d_getnetent_r>
+
+From F<d_getnetent_r.U>:
+
+This variable conditionally defines the C<HAS_GETNETENT_R> symbol,
+which indicates to the C program that the getnetent_r()
+routine is available.
+
+=item C<d_getnetprotos>
+
+From F<d_getnetprotos.U>:
+
+This variable conditionally defines the C<HAS_GETNET_PROTOS> symbol,
+which indicates to the C program that <netdb.h> supplies
+prototypes for the various getnet*() functions.
+See also F<netdbtype.U> for probing for various netdb types.
+
+=item C<d_getpagsz>
+
+From F<d_getpagsz.U>:
+
+This variable conditionally defines C<HAS_GETPAGESIZE> if getpagesize()
+is available to get the system page size.
+
+=item C<d_getpbyname>
+
+From F<d_getprotby.U>:
+
+This variable conditionally defines the C<HAS_GETPROTOBYNAME>
+symbol, which indicates to the C program that the
+getprotobyname() routine is available to look up protocols
+by their name.
+
+=item C<d_getpbynumber>
+
+From F<d_getprotby.U>:
+
+This variable conditionally defines the C<HAS_GETPROTOBYNUMBER>
+symbol, which indicates to the C program that the
+getprotobynumber() routine is available to look up protocols
+by their number.
+
+=item C<d_getpent>
+
+From F<d_getpent.U>:
+
+This variable conditionally defines C<HAS_GETPROTOENT> if getprotoent() is
+available to look up protocols in some data base or another.
+
+=item C<d_getpgid>
+
+From F<d_getpgid.U>:
+
+This variable conditionally defines the C<HAS_GETPGID> symbol, which
+indicates to the C program that the getpgid(pid) function
+is available to get the process group id.
+
+=item C<d_getpgrp>
+
+From F<d_getpgrp.U>:
+
+This variable conditionally defines C<HAS_GETPGRP> if getpgrp() is
+available to get the current process group.
+
+=item C<d_getpgrp2>
+
+From F<d_getpgrp2.U>:
+
+This variable conditionally defines the HAS_GETPGRP2 symbol, which
+indicates to the C program that the getpgrp2() (as in F<DG/C<UX>>) routine
+is available to get the current process group.
+
+=item C<d_getppid>
+
+From F<d_getppid.U>:
+
+This variable conditionally defines the C<HAS_GETPPID> symbol, which
+indicates to the C program that the getppid() routine is available
+to get the parent process C<ID>.
+
+=item C<d_getprior>
+
+From F<d_getprior.U>:
+
+This variable conditionally defines C<HAS_GETPRIORITY> if getpriority()
+is available to get a process's priority.
+
+=item C<d_getprotobyname_r>
+
+From F<d_getprotobyname_r.U>:
+
+This variable conditionally defines the C<HAS_GETPROTOBYNAME_R> symbol,
+which indicates to the C program that the getprotobyname_r()
+routine is available.
+
+=item C<d_getprotobynumber_r>
+
+From F<d_getprotobynumber_r.U>:
+
+This variable conditionally defines the C<HAS_GETPROTOBYNUMBER_R> symbol,
+which indicates to the C program that the getprotobynumber_r()
+routine is available.
+
+=item C<d_getprotoent_r>
+
+From F<d_getprotoent_r.U>:
+
+This variable conditionally defines the C<HAS_GETPROTOENT_R> symbol,
+which indicates to the C program that the getprotoent_r()
+routine is available.
+
+=item C<d_getprotoprotos>
+
+From F<d_getprotoprotos.U>:
+
+This variable conditionally defines the C<HAS_GETPROTO_PROTOS> symbol,
+which indicates to the C program that <netdb.h> supplies
+prototypes for the various getproto*() functions.
+See also F<netdbtype.U> for probing for various netdb types.
+
+=item C<d_getprpwnam>
+
+From F<d_getprpwnam.U>:
+
+This variable conditionally defines C<HAS_GETPRPWNAM> if getprpwnam() is
+available to retrieve protected (shadow) password entries by name.
+
+=item C<d_getpwent>
+
+From F<d_getpwent.U>:
+
+This variable conditionally defines the C<HAS_GETPWENT> symbol, which
+indicates to the C program that the getpwent() routine is available
+for sequential access of the passwd database.
+
+=item C<d_getpwent_r>
+
+From F<d_getpwent_r.U>:
+
+This variable conditionally defines the C<HAS_GETPWENT_R> symbol,
+which indicates to the C program that the getpwent_r()
+routine is available.
+
+=item C<d_getpwnam_r>
+
+From F<d_getpwnam_r.U>:
+
+This variable conditionally defines the C<HAS_GETPWNAM_R> symbol,
+which indicates to the C program that the getpwnam_r()
+routine is available.
+
+=item C<d_getpwuid_r>
+
+From F<d_getpwuid_r.U>:
+
+This variable conditionally defines the C<HAS_GETPWUID_R> symbol,
+which indicates to the C program that the getpwuid_r()
+routine is available.
+
+=item C<d_getsbyname>
+
+From F<d_getsrvby.U>:
+
+This variable conditionally defines the C<HAS_GETSERVBYNAME>
+symbol, which indicates to the C program that the
+getservbyname() routine is available to look up services
+by their name.
+
+=item C<d_getsbyport>
+
+From F<d_getsrvby.U>:
+
+This variable conditionally defines the C<HAS_GETSERVBYPORT>
+symbol, which indicates to the C program that the
+getservbyport() routine is available to look up services
+by their port.
+
+=item C<d_getsent>
+
+From F<d_getsent.U>:
+
+This variable conditionally defines C<HAS_GETSERVENT> if getservent() is
+available to look up network services in some data base or another.
+
+=item C<d_getservbyname_r>
+
+From F<d_getservbyname_r.U>:
+
+This variable conditionally defines the C<HAS_GETSERVBYNAME_R> symbol,
+which indicates to the C program that the getservbyname_r()
+routine is available.
+
+=item C<d_getservbyport_r>
+
+From F<d_getservbyport_r.U>:
+
+This variable conditionally defines the C<HAS_GETSERVBYPORT_R> symbol,
+which indicates to the C program that the getservbyport_r()
+routine is available.
+
+=item C<d_getservent_r>
+
+From F<d_getservent_r.U>:
+
+This variable conditionally defines the C<HAS_GETSERVENT_R> symbol,
+which indicates to the C program that the getservent_r()
+routine is available.
+
+=item C<d_getservprotos>
+
+From F<d_getservprotos.U>:
+
+This variable conditionally defines the C<HAS_GETSERV_PROTOS> symbol,
+which indicates to the C program that <netdb.h> supplies
+prototypes for the various getserv*() functions.
+See also F<netdbtype.U> for probing for various netdb types.
+
+=item C<d_getspnam>
+
+From F<d_getspnam.U>:
+
+This variable conditionally defines C<HAS_GETSPNAM> if getspnam() is
+available to retrieve SysV shadow password entries by name.
+
+=item C<d_getspnam_r>
+
+From F<d_getspnam_r.U>:
+
+This variable conditionally defines the C<HAS_GETSPNAM_R> symbol,
+which indicates to the C program that the getspnam_r()
+routine is available.
+
+=item C<d_gettimeod>
+
+From F<d_ftime.U>:
+
+This variable conditionally defines the C<HAS_GETTIMEOFDAY> symbol, which
+indicates that the gettimeofday() system call exists (to obtain a
+sub-second accuracy clock). You should probably include <sys/resource.h>.
+
+=item C<d_gmtime64>
+
+From F<d_timefuncs64.U>:
+
+This variable conditionally defines the HAS_GMTIME64 symbol, which
+indicates to the C program that the gmtime64 () routine is available.
+
+=item C<d_gmtime_r>
+
+From F<d_gmtime_r.U>:
+
+This variable conditionally defines the C<HAS_GMTIME_R> symbol,
+which indicates to the C program that the gmtime_r()
+routine is available.
+
+=item C<d_gnulibc>
+
+From F<d_gnulibc.U>:
+
+Defined if we're dealing with the C<GNU> C Library.
+
+=item C<d_grpasswd>
+
+From F<i_grp.U>:
+
+This variable conditionally defines C<GRPASSWD>, which indicates
+that struct group in <grp.h> contains gr_passwd.
+
+=item C<d_hasmntopt>
+
+From F<d_hasmntopt.U>:
+
+This variable conditionally defines the C<HAS_HASMNTOPT> symbol, which
+indicates to the C program that the hasmntopt() routine is available
+to query the mount options of file systems.
+
+=item C<d_htonl>
+
+From F<d_htonl.U>:
+
+This variable conditionally defines C<HAS_HTONL> if htonl() and its
+friends are available to do network order byte swapping.
+
+=item C<d_ilogbl>
+
+From F<d_ilogbl.U>:
+
+This variable conditionally defines the C<HAS_ILOGBL> symbol, which
+indicates to the C program that the ilogbl() routine is available.
+If scalbnl is also present we can emulate frexpl.
+
+=item C<d_inc_version_list>
+
+From F<inc_version_list.U>:
+
+This variable conditionally defines C<PERL_INC_VERSION_LIST>.
+It is set to undef when C<PERL_INC_VERSION_LIST> is empty.
+
+=item C<d_index>
+
+From F<d_strchr.U>:
+
+This variable conditionally defines C<HAS_INDEX> if index() and
+rindex() are available for string searching.
+
+=item C<d_inetaton>
+
+From F<d_inetaton.U>:
+
+This variable conditionally defines the C<HAS_INET_ATON> symbol, which
+indicates to the C program that the inet_aton() function is available
+to parse C<IP> address C<dotted-quad> strings.
+
+=item C<d_inetntop>
+
+From F<d_inetntop.U>:
+
+This variable conditionally defines the C<HAS_INETNTOP> symbol,
+which indicates to the C program that the inet_ntop() function
+is available.
+
+=item C<d_inetpton>
+
+From F<d_inetpton.U>:
+
+This variable conditionally defines the C<HAS_INETPTON> symbol,
+which indicates to the C program that the inet_pton() function
+is available.
+
+=item C<d_int64_t>
+
+From F<d_int64_t.U>:
+
+This symbol will be defined if the C compiler supports int64_t.
+
+=item C<d_isascii>
+
+From F<d_isascii.U>:
+
+This variable conditionally defines the C<HAS_ISASCII> constant,
+which indicates to the C program that isascii() is available.
+
+=item C<d_isfinite>
+
+From F<d_isfinite.U>:
+
+This variable conditionally defines the C<HAS_ISFINITE> symbol, which
+indicates to the C program that the isfinite() routine is available.
+
+=item C<d_isinf>
+
+From F<d_isinf.U>:
+
+This variable conditionally defines the C<HAS_ISINF> symbol, which
+indicates to the C program that the isinf() routine is available.
+
+=item C<d_isnan>
+
+From F<d_isnan.U>:
+
+This variable conditionally defines the C<HAS_ISNAN> symbol, which
+indicates to the C program that the isnan() routine is available.
+
+=item C<d_isnanl>
+
+From F<d_isnanl.U>:
+
+This variable conditionally defines the C<HAS_ISNANL> symbol, which
+indicates to the C program that the isnanl() routine is available.
+
+=item C<d_killpg>
+
+From F<d_killpg.U>:
+
+This variable conditionally defines the C<HAS_KILLPG> symbol, which
+indicates to the C program that the killpg() routine is available
+to kill process groups.
+
+=item C<d_lchown>
+
+From F<d_lchown.U>:
+
+This variable conditionally defines the C<HAS_LCHOWN> symbol, which
+indicates to the C program that the lchown() routine is available
+to operate on a symbolic link (instead of following the link).
+
+=item C<d_ldbl_dig>
+
+From F<d_ldbl_dig.U>:
+
+This variable conditionally defines d_ldbl_dig if this system's
+header files provide C<LDBL_DIG>, which is the number of significant
+digits in a long double precision number.
+
+=item C<d_libm_lib_version>
+
+From F<d_libm_lib_version.U>:
+
+This variable conditionally defines the C<LIBM_LIB_VERSION> symbol,
+which indicates to the C program that F<math.h> defines C<_LIB_VERSION>
+being available in libm
+
+=item C<d_link>
+
+From F<d_link.U>:
+
+This variable conditionally defines C<HAS_LINK> if link() is
+available to create hard links.
+
+=item C<d_localtime64>
+
+From F<d_timefuncs64.U>:
+
+This variable conditionally defines the HAS_LOCALTIME64 symbol, which
+indicates to the C program that the localtime64 () routine is available.
+
+=item C<d_localtime_r>
+
+From F<d_localtime_r.U>:
+
+This variable conditionally defines the C<HAS_LOCALTIME_R> symbol,
+which indicates to the C program that the localtime_r()
+routine is available.
+
+=item C<d_localtime_r_needs_tzset>
+
+From F<d_localtime_r.U>:
+
+This variable conditionally defines the C<LOCALTIME_R_NEEDS_TZSET>
+symbol, which makes us call tzset before localtime_r()
+
+=item C<d_locconv>
+
+From F<d_locconv.U>:
+
+This variable conditionally defines C<HAS_LOCALECONV> if localeconv() is
+available for numeric and monetary formatting conventions.
+
+=item C<d_lockf>
+
+From F<d_lockf.U>:
+
+This variable conditionally defines C<HAS_LOCKF> if lockf() is
+available to do file locking.
+
+=item C<d_longdbl>
+
+From F<d_longdbl.U>:
+
+This variable conditionally defines C<HAS_LONG_DOUBLE> if
+the long double type is supported.
+
+=item C<d_longlong>
+
+From F<d_longlong.U>:
+
+This variable conditionally defines C<HAS_LONG_LONG> if
+the long long type is supported.
+
+=item C<d_lseekproto>
+
+From F<d_lseekproto.U>:
+
+This variable conditionally defines the C<HAS_LSEEK_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the lseek() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_lstat>
+
+From F<d_lstat.U>:
+
+This variable conditionally defines C<HAS_LSTAT> if lstat() is
+available to do file stats on symbolic links.
+
+=item C<d_madvise>
+
+From F<d_madvise.U>:
+
+This variable conditionally defines C<HAS_MADVISE> if madvise() is
+available to map a file into memory.
+
+=item C<d_malloc_good_size>
+
+From F<d_malloc_size.U>:
+
+This symbol, if defined, indicates that the malloc_good_size
+routine is available for use.
+
+=item C<d_malloc_size>
+
+From F<d_malloc_size.U>:
+
+This symbol, if defined, indicates that the malloc_size
+routine is available for use.
+
+=item C<d_mblen>
+
+From F<d_mblen.U>:
+
+This variable conditionally defines the C<HAS_MBLEN> symbol, which
+indicates to the C program that the mblen() routine is available
+to find the number of bytes in a multibye character.
+
+=item C<d_mbstowcs>
+
+From F<d_mbstowcs.U>:
+
+This variable conditionally defines the C<HAS_MBSTOWCS> symbol, which
+indicates to the C program that the mbstowcs() routine is available
+to convert a multibyte string into a wide character string.
+
+=item C<d_mbtowc>
+
+From F<d_mbtowc.U>:
+
+This variable conditionally defines the C<HAS_MBTOWC> symbol, which
+indicates to the C program that the mbtowc() routine is available
+to convert multibyte to a wide character.
+
+=item C<d_memchr>
+
+From F<d_memchr.U>:
+
+This variable conditionally defines the C<HAS_MEMCHR> symbol, which
+indicates to the C program that the memchr() routine is available
+to locate characters within a C string.
+
+=item C<d_memcmp>
+
+From F<d_memcmp.U>:
+
+This variable conditionally defines the C<HAS_MEMCMP> symbol, which
+indicates to the C program that the memcmp() routine is available
+to compare blocks of memory.
+
+=item C<d_memcpy>
+
+From F<d_memcpy.U>:
+
+This variable conditionally defines the C<HAS_MEMCPY> symbol, which
+indicates to the C program that the memcpy() routine is available
+to copy blocks of memory.
+
+=item C<d_memmove>
+
+From F<d_memmove.U>:
+
+This variable conditionally defines the C<HAS_MEMMOVE> symbol, which
+indicates to the C program that the memmove() routine is available
+to copy potentatially overlapping blocks of memory.
+
+=item C<d_memset>
+
+From F<d_memset.U>:
+
+This variable conditionally defines the C<HAS_MEMSET> symbol, which
+indicates to the C program that the memset() routine is available
+to set blocks of memory.
+
+=item C<d_mkdir>
+
+From F<d_mkdir.U>:
+
+This variable conditionally defines the C<HAS_MKDIR> symbol, which
+indicates to the C program that the mkdir() routine is available
+to create F<directories.>.
+
+=item C<d_mkdtemp>
+
+From F<d_mkdtemp.U>:
+
+This variable conditionally defines the C<HAS_MKDTEMP> symbol, which
+indicates to the C program that the mkdtemp() routine is available
+to exclusively create a uniquely named temporary directory.
+
+=item C<d_mkfifo>
+
+From F<d_mkfifo.U>:
+
+This variable conditionally defines the C<HAS_MKFIFO> symbol, which
+indicates to the C program that the mkfifo() routine is available.
+
+=item C<d_mkstemp>
+
+From F<d_mkstemp.U>:
+
+This variable conditionally defines the C<HAS_MKSTEMP> symbol, which
+indicates to the C program that the mkstemp() routine is available
+to exclusively create and open a uniquely named temporary file.
+
+=item C<d_mkstemps>
+
+From F<d_mkstemps.U>:
+
+This variable conditionally defines the C<HAS_MKSTEMPS> symbol, which
+indicates to the C program that the mkstemps() routine is available
+to exclusively create and open a uniquely named (with a suffix)
+temporary file.
+
+=item C<d_mktime>
+
+From F<d_mktime.U>:
+
+This variable conditionally defines the C<HAS_MKTIME> symbol, which
+indicates to the C program that the mktime() routine is available.
+
+=item C<d_mktime64>
+
+From F<d_timefuncs64.U>:
+
+This variable conditionally defines the HAS_MKTIME64 symbol, which
+indicates to the C program that the mktime64 () routine is available.
+
+=item C<d_mmap>
+
+From F<d_mmap.U>:
+
+This variable conditionally defines C<HAS_MMAP> if mmap() is
+available to map a file into memory.
+
+=item C<d_modfl>
+
+From F<d_modfl.U>:
+
+This variable conditionally defines the C<HAS_MODFL> symbol, which
+indicates to the C program that the modfl() routine is available.
+
+=item C<d_modfl_pow32_bug>
+
+From F<d_modfl.U>:
+
+This variable conditionally defines the HAS_MODFL_POW32_BUG symbol,
+which indicates that modfl() is broken for long doubles >= pow(2, 32).
+For example from 4294967303.150000 one would get 4294967302.000000
+and 1.150000. The bug has been seen in certain versions of glibc,
+release 2.2.2 is known to be okay.
+
+=item C<d_modflproto>
+
+From F<d_modfl.U>:
+
+This symbol, if defined, indicates that the system provides
+a prototype for the modfl() function. Otherwise, it is up
+to the program to supply one. C99 says it should be
+long double modfl(long double, long double *);
+
+=item C<d_mprotect>
+
+From F<d_mprotect.U>:
+
+This variable conditionally defines C<HAS_MPROTECT> if mprotect() is
+available to modify the access protection of a memory mapped file.
+
+=item C<d_msg>
+
+From F<d_msg.U>:
+
+This variable conditionally defines the C<HAS_MSG> symbol, which
+indicates that the entire msg*(2) library is present.
+
+=item C<d_msg_ctrunc>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_MSG_CTRUNC> symbol,
+which indicates that the C<MSG_CTRUNC> is available. #ifdef is
+not enough because it may be an enum, glibc has been known to do this.
+
+=item C<d_msg_dontroute>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_MSG_DONTROUTE> symbol,
+which indicates that the C<MSG_DONTROUTE> is available. #ifdef is
+not enough because it may be an enum, glibc has been known to do this.
+
+=item C<d_msg_oob>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_MSG_OOB> symbol,
+which indicates that the C<MSG_OOB> is available. #ifdef is
+not enough because it may be an enum, glibc has been known to do this.
+
+=item C<d_msg_peek>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_MSG_PEEK> symbol,
+which indicates that the C<MSG_PEEK> is available. #ifdef is
+not enough because it may be an enum, glibc has been known to do this.
+
+=item C<d_msg_proxy>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_MSG_PROXY> symbol,
+which indicates that the C<MSG_PROXY> is available. #ifdef is
+not enough because it may be an enum, glibc has been known to do this.
+
+=item C<d_msgctl>
+
+From F<d_msgctl.U>:
+
+This variable conditionally defines the C<HAS_MSGCTL> symbol, which
+indicates to the C program that the msgctl() routine is available.
+
+=item C<d_msgget>
+
+From F<d_msgget.U>:
+
+This variable conditionally defines the C<HAS_MSGGET> symbol, which
+indicates to the C program that the msgget() routine is available.
+
+=item C<d_msghdr_s>
+
+From F<d_msghdr_s.U>:
+
+This variable conditionally defines the C<HAS_STRUCT_MSGHDR> symbol,
+which indicates that the struct msghdr is supported.
+
+=item C<d_msgrcv>
+
+From F<d_msgrcv.U>:
+
+This variable conditionally defines the C<HAS_MSGRCV> symbol, which
+indicates to the C program that the msgrcv() routine is available.
+
+=item C<d_msgsnd>
+
+From F<d_msgsnd.U>:
+
+This variable conditionally defines the C<HAS_MSGSND> symbol, which
+indicates to the C program that the msgsnd() routine is available.
+
+=item C<d_msync>
+
+From F<d_msync.U>:
+
+This variable conditionally defines C<HAS_MSYNC> if msync() is
+available to synchronize a mapped file.
+
+=item C<d_munmap>
+
+From F<d_munmap.U>:
+
+This variable conditionally defines C<HAS_MUNMAP> if munmap() is
+available to unmap a region mapped by mmap().
+
+=item C<d_mymalloc>
+
+From F<mallocsrc.U>:
+
+This variable conditionally defines C<MYMALLOC> in case other parts
+of the source want to take special action if C<MYMALLOC> is used.
+This may include different sorts of profiling or error detection.
+
+=item C<d_ndbm>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<HAS_NDBM> symbol, which
+indicates that both the F<ndbm.h> include file and an appropriate ndbm
+library exist. Consult the different i_*ndbm variables
+to find out the actual include location. Sometimes, a system has the
+header file but not the library. This variable will only be set if
+the system has both.
+
+=item C<d_ndbm_h_uses_prototypes>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<NDBM_H_USES_PROTOTYPES> symbol,
+which indicates that the F<ndbm.h> include file uses real C<ANSI> C
+prototypes instead of K&R style function declarations. K&R style
+declarations are unsupported in C++, so the include file requires
+special handling when using a C++ compiler and this variable is
+undefined. Consult the different d_*ndbm_h_uses_prototypes variables
+to get the same information for alternative F<ndbm.h> include files.
+
+=item C<d_nice>
+
+From F<d_nice.U>:
+
+This variable conditionally defines the C<HAS_NICE> symbol, which
+indicates to the C program that the nice() routine is available.
+
+=item C<d_nl_langinfo>
+
+From F<d_nl_langinfo.U>:
+
+This variable conditionally defines the C<HAS_NL_LANGINFO> symbol, which
+indicates to the C program that the nl_langinfo() routine is available.
+
+=item C<d_nv_preserves_uv>
+
+From F<perlxv.U>:
+
+This variable indicates whether a variable of type nvtype
+can preserve all the bits a variable of type uvtype.
+
+=item C<d_nv_zero_is_allbits_zero>
+
+From F<perlxv.U>:
+
+This variable indicates whether a variable of type nvtype
+stores 0.0 in memory as all bits zero.
+
+=item C<d_off64_t>
+
+From F<d_off64_t.U>:
+
+This symbol will be defined if the C compiler supports off64_t.
+
+=item C<d_old_pthread_create_joinable>
+
+From F<d_pthrattrj.U>:
+
+This variable conditionally defines pthread_create_joinable.
+undef if F<pthread.h> defines C<PTHREAD_CREATE_JOINABLE>.
+
+=item C<d_oldpthreads>
+
+From F<usethreads.U>:
+
+This variable conditionally defines the C<OLD_PTHREADS_API> symbol,
+and indicates that Perl should be built to use the old
+draft C<POSIX> threads C<API>. This is only potentially meaningful if
+usethreads is set.
+
+=item C<d_oldsock>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<OLDSOCKET> symbol, which
+indicates that the C<BSD> socket interface is based on 4.1c and not 4.2.
+
+=item C<d_open3>
+
+From F<d_open3.U>:
+
+This variable conditionally defines the HAS_OPEN3 manifest constant,
+which indicates to the C program that the 3 argument version of
+the open(2) function is available.
+
+=item C<d_pathconf>
+
+From F<d_pathconf.U>:
+
+This variable conditionally defines the C<HAS_PATHCONF> symbol, which
+indicates to the C program that the pathconf() routine is available
+to determine file-system related limits and options associated
+with a given filename.
+
+=item C<d_pause>
+
+From F<d_pause.U>:
+
+This variable conditionally defines the C<HAS_PAUSE> symbol, which
+indicates to the C program that the pause() routine is available
+to suspend a process until a signal is received.
+
+=item C<d_perl_otherlibdirs>
+
+From F<otherlibdirs.U>:
+
+This variable conditionally defines C<PERL_OTHERLIBDIRS>, which
+contains a colon-separated set of paths for the perl binary to
+include in @C<INC>. See also otherlibdirs.
+
+=item C<d_phostname>
+
+From F<d_gethname.U>:
+
+This variable conditionally defines the C<HAS_PHOSTNAME> symbol, which
+contains the shell command which, when fed to popen(), may be
+used to derive the host name.
+
+=item C<d_pipe>
+
+From F<d_pipe.U>:
+
+This variable conditionally defines the C<HAS_PIPE> symbol, which
+indicates to the C program that the pipe() routine is available
+to create an inter-process channel.
+
+=item C<d_poll>
+
+From F<d_poll.U>:
+
+This variable conditionally defines the C<HAS_POLL> symbol, which
+indicates to the C program that the poll() routine is available
+to poll active file descriptors.
+
+=item C<d_portable>
+
+From F<d_portable.U>:
+
+This variable conditionally defines the C<PORTABLE> symbol, which
+indicates to the C program that it should not assume that it is
+running on the machine it was compiled on.
+
+=item C<d_PRId64>
+
+From F<quadfio.U>:
+
+This variable conditionally defines the PERL_PRId64 symbol, which
+indiciates that stdio has a symbol to print 64-bit decimal numbers.
+
+=item C<d_PRIeldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to print long doubles.
+
+=item C<d_PRIEUldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to print long doubles.
+The C<U> in the name is to separate this from d_PRIeldbl so that even
+case-blind systems can see the difference.
+
+=item C<d_PRIfldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to print long doubles.
+
+=item C<d_PRIFUldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to print long doubles.
+The C<U> in the name is to separate this from d_PRIfldbl so that even
+case-blind systems can see the difference.
+
+=item C<d_PRIgldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to print long doubles.
+
+=item C<d_PRIGUldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to print long doubles.
+The C<U> in the name is to separate this from d_PRIgldbl so that even
+case-blind systems can see the difference.
+
+=item C<d_PRIi64>
+
+From F<quadfio.U>:
+
+This variable conditionally defines the PERL_PRIi64 symbol, which
+indiciates that stdio has a symbol to print 64-bit decimal numbers.
+
+=item C<d_printf_format_null>
+
+From F<d_attribut.U>:
+
+This variable conditionally defines C<PRINTF_FORMAT_NULL_OK>, which
+indicates the C compiler allows printf-like formats to be null.
+
+=item C<d_PRIo64>
+
+From F<quadfio.U>:
+
+This variable conditionally defines the PERL_PRIo64 symbol, which
+indiciates that stdio has a symbol to print 64-bit octal numbers.
+
+=item C<d_PRIu64>
+
+From F<quadfio.U>:
+
+This variable conditionally defines the PERL_PRIu64 symbol, which
+indiciates that stdio has a symbol to print 64-bit unsigned decimal
+numbers.
+
+=item C<d_PRIx64>
+
+From F<quadfio.U>:
+
+This variable conditionally defines the PERL_PRIx64 symbol, which
+indiciates that stdio has a symbol to print 64-bit hexadecimal numbers.
+
+=item C<d_PRIXU64>
+
+From F<quadfio.U>:
+
+This variable conditionally defines the PERL_PRIXU64 symbol, which
+indiciates that stdio has a symbol to print 64-bit hExADECimAl numbers.
+The C<U> in the name is to separate this from d_PRIx64 so that even
+case-blind systems can see the difference.
+
+=item C<d_procselfexe>
+
+From F<d_procselfexe.U>:
+
+Defined if $procselfexe is symlink to the absolute
+pathname of the executing program.
+
+=item C<d_pseudofork>
+
+From F<d_vfork.U>:
+
+This variable conditionally defines the C<HAS_PSEUDOFORK> symbol,
+which indicates that an emulation of the fork routine is available.
+
+=item C<d_pthread_atfork>
+
+From F<d_pthread_atfork.U>:
+
+This variable conditionally defines the C<HAS_PTHREAD_ATFORK> symbol,
+which indicates to the C program that the pthread_atfork()
+routine is available.
+
+=item C<d_pthread_attr_setscope>
+
+From F<d_pthread_attr_ss.U>:
+
+This variable conditionally defines C<HAS_PTHREAD_ATTR_SETSCOPE> if
+pthread_attr_setscope() is available to set the contention scope
+attribute of a thread attribute object.
+
+=item C<d_pthread_yield>
+
+From F<d_pthread_y.U>:
+
+This variable conditionally defines the C<HAS_PTHREAD_YIELD>
+symbol if the pthread_yield routine is available to yield
+the execution of the current thread.
+
+=item C<d_pwage>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWAGE>, which indicates
+that struct passwd contains pw_age.
+
+=item C<d_pwchange>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWCHANGE>, which indicates
+that struct passwd contains pw_change.
+
+=item C<d_pwclass>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWCLASS>, which indicates
+that struct passwd contains pw_class.
+
+=item C<d_pwcomment>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWCOMMENT>, which indicates
+that struct passwd contains pw_comment.
+
+=item C<d_pwexpire>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWEXPIRE>, which indicates
+that struct passwd contains pw_expire.
+
+=item C<d_pwgecos>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWGECOS>, which indicates
+that struct passwd contains pw_gecos.
+
+=item C<d_pwpasswd>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWPASSWD>, which indicates
+that struct passwd contains pw_passwd.
+
+=item C<d_pwquota>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<PWQUOTA>, which indicates
+that struct passwd contains pw_quota.
+
+=item C<d_qgcvt>
+
+From F<d_qgcvt.U>:
+
+This variable conditionally defines the C<HAS_QGCVT> symbol, which
+indicates to the C program that the qgcvt() routine is available.
+
+=item C<d_quad>
+
+From F<quadtype.U>:
+
+This variable, if defined, tells that there's a 64-bit integer type,
+quadtype.
+
+=item C<d_random_r>
+
+From F<d_random_r.U>:
+
+This variable conditionally defines the C<HAS_RANDOM_R> symbol,
+which indicates to the C program that the random_r()
+routine is available.
+
+=item C<d_readdir>
+
+From F<d_readdir.U>:
+
+This variable conditionally defines C<HAS_READDIR> if readdir() is
+available to read directory entries.
+
+=item C<d_readdir64_r>
+
+From F<d_readdir64_r.U>:
+
+This variable conditionally defines the HAS_READDIR64_R symbol,
+which indicates to the C program that the readdir64_r()
+routine is available.
+
+=item C<d_readdir_r>
+
+From F<d_readdir_r.U>:
+
+This variable conditionally defines the C<HAS_READDIR_R> symbol,
+which indicates to the C program that the readdir_r()
+routine is available.
+
+=item C<d_readlink>
+
+From F<d_readlink.U>:
+
+This variable conditionally defines the C<HAS_READLINK> symbol, which
+indicates to the C program that the readlink() routine is available
+to read the value of a symbolic link.
+
+=item C<d_readv>
+
+From F<d_readv.U>:
+
+This variable conditionally defines the C<HAS_READV> symbol, which
+indicates to the C program that the readv() routine is available.
+
+=item C<d_recvmsg>
+
+From F<d_recvmsg.U>:
+
+This variable conditionally defines the C<HAS_RECVMSG> symbol, which
+indicates to the C program that the recvmsg() routine is available.
+
+=item C<d_rename>
+
+From F<d_rename.U>:
+
+This variable conditionally defines the C<HAS_RENAME> symbol, which
+indicates to the C program that the rename() routine is available
+to rename files.
+
+=item C<d_rewinddir>
+
+From F<d_readdir.U>:
+
+This variable conditionally defines C<HAS_REWINDDIR> if rewinddir() is
+available.
+
+=item C<d_rmdir>
+
+From F<d_rmdir.U>:
+
+This variable conditionally defines C<HAS_RMDIR> if rmdir() is
+available to remove directories.
+
+=item C<d_safebcpy>
+
+From F<d_safebcpy.U>:
+
+This variable conditionally defines the C<HAS_SAFE_BCOPY> symbol if
+the bcopy() routine can do overlapping copies. Normally, you
+should probably use memmove().
+
+=item C<d_safemcpy>
+
+From F<d_safemcpy.U>:
+
+This variable conditionally defines the C<HAS_SAFE_MEMCPY> symbol if
+the memcpy() routine can do overlapping copies.
+For overlapping copies, memmove() should be used, if available.
+
+=item C<d_sanemcmp>
+
+From F<d_sanemcmp.U>:
+
+This variable conditionally defines the C<HAS_SANE_MEMCMP> symbol if
+the memcpy() routine is available and can be used to compare relative
+magnitudes of chars with their high bits set.
+
+=item C<d_sbrkproto>
+
+From F<d_sbrkproto.U>:
+
+This variable conditionally defines the C<HAS_SBRK_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the sbrk() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_scalbnl>
+
+From F<d_scalbnl.U>:
+
+This variable conditionally defines the C<HAS_SCALBNL> symbol, which
+indicates to the C program that the scalbnl() routine is available.
+If ilogbl is also present we can emulate frexpl.
+
+=item C<d_sched_yield>
+
+From F<d_pthread_y.U>:
+
+This variable conditionally defines the C<HAS_SCHED_YIELD>
+symbol if the sched_yield routine is available to yield
+the execution of the current thread.
+
+=item C<d_scm_rights>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_SCM_RIGHTS> symbol,
+which indicates that the C<SCM_RIGHTS> is available. #ifdef is
+not enough because it may be an enum, glibc has been known to do this.
+
+=item C<d_SCNfldbl>
+
+From F<longdblfio.U>:
+
+This variable conditionally defines the PERL_PRIfldbl symbol, which
+indiciates that stdio has a symbol to scan long doubles.
+
+=item C<d_seekdir>
+
+From F<d_readdir.U>:
+
+This variable conditionally defines C<HAS_SEEKDIR> if seekdir() is
+available.
+
+=item C<d_select>
+
+From F<d_select.U>:
+
+This variable conditionally defines C<HAS_SELECT> if select() is
+available to select active file descriptors. A <sys/time.h>
+inclusion may be necessary for the timeout field.
+
+=item C<d_sem>
+
+From F<d_sem.U>:
+
+This variable conditionally defines the C<HAS_SEM> symbol, which
+indicates that the entire sem*(2) library is present.
+
+=item C<d_semctl>
+
+From F<d_semctl.U>:
+
+This variable conditionally defines the C<HAS_SEMCTL> symbol, which
+indicates to the C program that the semctl() routine is available.
+
+=item C<d_semctl_semid_ds>
+
+From F<d_union_semun.U>:
+
+This variable conditionally defines C<USE_SEMCTL_SEMID_DS>, which
+indicates that struct semid_ds * is to be used for semctl C<IPC_STAT>.
+
+=item C<d_semctl_semun>
+
+From F<d_union_semun.U>:
+
+This variable conditionally defines C<USE_SEMCTL_SEMUN>, which
+indicates that union semun is to be used for semctl C<IPC_STAT>.
+
+=item C<d_semget>
+
+From F<d_semget.U>:
+
+This variable conditionally defines the C<HAS_SEMGET> symbol, which
+indicates to the C program that the semget() routine is available.
+
+=item C<d_semop>
+
+From F<d_semop.U>:
+
+This variable conditionally defines the C<HAS_SEMOP> symbol, which
+indicates to the C program that the semop() routine is available.
+
+=item C<d_sendmsg>
+
+From F<d_sendmsg.U>:
+
+This variable conditionally defines the C<HAS_SENDMSG> symbol, which
+indicates to the C program that the sendmsg() routine is available.
+
+=item C<d_setegid>
+
+From F<d_setegid.U>:
+
+This variable conditionally defines the C<HAS_SETEGID> symbol, which
+indicates to the C program that the setegid() routine is available
+to change the effective gid of the current program.
+
+=item C<d_seteuid>
+
+From F<d_seteuid.U>:
+
+This variable conditionally defines the C<HAS_SETEUID> symbol, which
+indicates to the C program that the seteuid() routine is available
+to change the effective uid of the current program.
+
+=item C<d_setgrent>
+
+From F<d_setgrent.U>:
+
+This variable conditionally defines the C<HAS_SETGRENT> symbol, which
+indicates to the C program that the setgrent() routine is available
+for initializing sequential access to the group database.
+
+=item C<d_setgrent_r>
+
+From F<d_setgrent_r.U>:
+
+This variable conditionally defines the C<HAS_SETGRENT_R> symbol,
+which indicates to the C program that the setgrent_r()
+routine is available.
+
+=item C<d_setgrps>
+
+From F<d_setgrps.U>:
+
+This variable conditionally defines the C<HAS_SETGROUPS> symbol, which
+indicates to the C program that the setgroups() routine is available
+to set the list of process groups.
+
+=item C<d_sethent>
+
+From F<d_sethent.U>:
+
+This variable conditionally defines C<HAS_SETHOSTENT> if sethostent() is
+available.
+
+=item C<d_sethostent_r>
+
+From F<d_sethostent_r.U>:
+
+This variable conditionally defines the C<HAS_SETHOSTENT_R> symbol,
+which indicates to the C program that the sethostent_r()
+routine is available.
+
+=item C<d_setitimer>
+
+From F<d_setitimer.U>:
+
+This variable conditionally defines the C<HAS_SETITIMER> symbol, which
+indicates to the C program that the setitimer() routine is available.
+
+=item C<d_setlinebuf>
+
+From F<d_setlnbuf.U>:
+
+This variable conditionally defines the C<HAS_SETLINEBUF> symbol, which
+indicates to the C program that the setlinebuf() routine is available
+to change stderr or stdout from block-buffered or unbuffered to a
+line-buffered mode.
+
+=item C<d_setlocale>
+
+From F<d_setlocale.U>:
+
+This variable conditionally defines C<HAS_SETLOCALE> if setlocale() is
+available to handle locale-specific ctype implementations.
+
+=item C<d_setlocale_r>
+
+From F<d_setlocale_r.U>:
+
+This variable conditionally defines the C<HAS_SETLOCALE_R> symbol,
+which indicates to the C program that the setlocale_r()
+routine is available.
+
+=item C<d_setnent>
+
+From F<d_setnent.U>:
+
+This variable conditionally defines C<HAS_SETNETENT> if setnetent() is
+available.
+
+=item C<d_setnetent_r>
+
+From F<d_setnetent_r.U>:
+
+This variable conditionally defines the C<HAS_SETNETENT_R> symbol,
+which indicates to the C program that the setnetent_r()
+routine is available.
+
+=item C<d_setpent>
+
+From F<d_setpent.U>:
+
+This variable conditionally defines C<HAS_SETPROTOENT> if setprotoent() is
+available.
+
+=item C<d_setpgid>
+
+From F<d_setpgid.U>:
+
+This variable conditionally defines the C<HAS_SETPGID> symbol if the
+setpgid(pid, gpid) function is available to set process group C<ID>.
+
+=item C<d_setpgrp>
+
+From F<d_setpgrp.U>:
+
+This variable conditionally defines C<HAS_SETPGRP> if setpgrp() is
+available to set the current process group.
+
+=item C<d_setpgrp2>
+
+From F<d_setpgrp2.U>:
+
+This variable conditionally defines the HAS_SETPGRP2 symbol, which
+indicates to the C program that the setpgrp2() (as in F<DG/C<UX>>) routine
+is available to set the current process group.
+
+=item C<d_setprior>
+
+From F<d_setprior.U>:
+
+This variable conditionally defines C<HAS_SETPRIORITY> if setpriority()
+is available to set a process's priority.
+
+=item C<d_setproctitle>
+
+From F<d_setproctitle.U>:
+
+This variable conditionally defines the C<HAS_SETPROCTITLE> symbol,
+which indicates to the C program that the setproctitle() routine
+is available.
+
+=item C<d_setprotoent_r>
+
+From F<d_setprotoent_r.U>:
+
+This variable conditionally defines the C<HAS_SETPROTOENT_R> symbol,
+which indicates to the C program that the setprotoent_r()
+routine is available.
+
+=item C<d_setpwent>
+
+From F<d_setpwent.U>:
+
+This variable conditionally defines the C<HAS_SETPWENT> symbol, which
+indicates to the C program that the setpwent() routine is available
+for initializing sequential access to the passwd database.
+
+=item C<d_setpwent_r>
+
+From F<d_setpwent_r.U>:
+
+This variable conditionally defines the C<HAS_SETPWENT_R> symbol,
+which indicates to the C program that the setpwent_r()
+routine is available.
+
+=item C<d_setregid>
+
+From F<d_setregid.U>:
+
+This variable conditionally defines C<HAS_SETREGID> if setregid() is
+available to change the real and effective gid of the current
+process.
+
+=item C<d_setresgid>
+
+From F<d_setregid.U>:
+
+This variable conditionally defines C<HAS_SETRESGID> if setresgid() is
+available to change the real, effective and saved gid of the current
+process.
+
+=item C<d_setresuid>
+
+From F<d_setreuid.U>:
+
+This variable conditionally defines C<HAS_SETREUID> if setresuid() is
+available to change the real, effective and saved uid of the current
+process.
+
+=item C<d_setreuid>
+
+From F<d_setreuid.U>:
+
+This variable conditionally defines C<HAS_SETREUID> if setreuid() is
+available to change the real and effective uid of the current
+process.
+
+=item C<d_setrgid>
+
+From F<d_setrgid.U>:
+
+This variable conditionally defines the C<HAS_SETRGID> symbol, which
+indicates to the C program that the setrgid() routine is available
+to change the real gid of the current program.
+
+=item C<d_setruid>
+
+From F<d_setruid.U>:
+
+This variable conditionally defines the C<HAS_SETRUID> symbol, which
+indicates to the C program that the setruid() routine is available
+to change the real uid of the current program.
+
+=item C<d_setsent>
+
+From F<d_setsent.U>:
+
+This variable conditionally defines C<HAS_SETSERVENT> if setservent() is
+available.
+
+=item C<d_setservent_r>
+
+From F<d_setservent_r.U>:
+
+This variable conditionally defines the C<HAS_SETSERVENT_R> symbol,
+which indicates to the C program that the setservent_r()
+routine is available.
+
+=item C<d_setsid>
+
+From F<d_setsid.U>:
+
+This variable conditionally defines C<HAS_SETSID> if setsid() is
+available to set the process group C<ID>.
+
+=item C<d_setvbuf>
+
+From F<d_setvbuf.U>:
+
+This variable conditionally defines the C<HAS_SETVBUF> symbol, which
+indicates to the C program that the setvbuf() routine is available
+to change buffering on an open stdio stream.
+
+=item C<d_sfio>
+
+From F<d_sfio.U>:
+
+This variable conditionally defines the C<USE_SFIO> symbol,
+and indicates whether sfio is available (and should be used).
+
+=item C<d_shm>
+
+From F<d_shm.U>:
+
+This variable conditionally defines the C<HAS_SHM> symbol, which
+indicates that the entire shm*(2) library is present.
+
+=item C<d_shmat>
+
+From F<d_shmat.U>:
+
+This variable conditionally defines the C<HAS_SHMAT> symbol, which
+indicates to the C program that the shmat() routine is available.
+
+=item C<d_shmatprototype>
+
+From F<d_shmat.U>:
+
+This variable conditionally defines the C<HAS_SHMAT_PROTOTYPE>
+symbol, which indicates that F<sys/shm.h> has a prototype for
+shmat.
+
+=item C<d_shmctl>
+
+From F<d_shmctl.U>:
+
+This variable conditionally defines the C<HAS_SHMCTL> symbol, which
+indicates to the C program that the shmctl() routine is available.
+
+=item C<d_shmdt>
+
+From F<d_shmdt.U>:
+
+This variable conditionally defines the C<HAS_SHMDT> symbol, which
+indicates to the C program that the shmdt() routine is available.
+
+=item C<d_shmget>
+
+From F<d_shmget.U>:
+
+This variable conditionally defines the C<HAS_SHMGET> symbol, which
+indicates to the C program that the shmget() routine is available.
+
+=item C<d_sigaction>
+
+From F<d_sigaction.U>:
+
+This variable conditionally defines the C<HAS_SIGACTION> symbol, which
+indicates that the Vr4 sigaction() routine is available.
+
+=item C<d_signbit>
+
+From F<d_signbit.U>:
+
+This variable conditionally defines the C<HAS_SIGNBIT> symbol, which
+indicates to the C program that the signbit() routine is available
+and safe to use with perl's intern C<NV> type.
+
+=item C<d_sigprocmask>
+
+From F<d_sigprocmask.U>:
+
+This variable conditionally defines C<HAS_SIGPROCMASK>
+if sigprocmask() is available to examine or change the signal mask
+of the calling process.
+
+=item C<d_sigsetjmp>
+
+From F<d_sigsetjmp.U>:
+
+This variable conditionally defines the C<HAS_SIGSETJMP> symbol,
+which indicates that the sigsetjmp() routine is available to
+call setjmp() and optionally save the process's signal mask.
+
+=item C<d_sitearch>
+
+From F<sitearch.U>:
+
+This variable conditionally defines C<SITEARCH> to hold the pathname
+of architecture-dependent library files for $package. If
+$sitearch is the same as $archlib, then this is set to undef.
+
+=item C<d_snprintf>
+
+From F<d_snprintf.U>:
+
+This variable conditionally defines the C<HAS_SNPRINTF> symbol, which
+indicates to the C program that the snprintf () library function
+is available.
+
+=item C<d_sockatmark>
+
+From F<d_sockatmark.U>:
+
+This variable conditionally defines the C<HAS_SOCKATMARK> symbol, which
+indicates to the C program that the sockatmark() routine is available.
+
+=item C<d_sockatmarkproto>
+
+From F<d_sockatmarkproto.U>:
+
+This variable conditionally defines the C<HAS_SOCKATMARK_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the sockatmark() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_socket>
+
+From F<d_socket.U>:
+
+This variable conditionally defines C<HAS_SOCKET>, which indicates
+that the C<BSD> socket interface is supported.
+
+=item C<d_socklen_t>
+
+From F<d_socklen_t.U>:
+
+This symbol will be defined if the C compiler supports socklen_t.
+
+=item C<d_sockpair>
+
+From F<d_socket.U>:
+
+This variable conditionally defines the C<HAS_SOCKETPAIR> symbol, which
+indicates that the C<BSD> socketpair() is supported.
+
+=item C<d_socks5_init>
+
+From F<d_socks5_init.U>:
+
+This variable conditionally defines the HAS_SOCKS5_INIT symbol, which
+indicates to the C program that the socks5_init() routine is available.
+
+=item C<d_sprintf_returns_strlen>
+
+From F<d_sprintf_len.U>:
+
+This variable defines whether sprintf returns the length of the string
+(as per the C<ANSI> spec). Some C libraries retain compatibility with
+pre-C<ANSI> C and return a pointer to the passed in buffer; for these
+this variable will be undef.
+
+=item C<d_sqrtl>
+
+From F<d_sqrtl.U>:
+
+This variable conditionally defines the C<HAS_SQRTL> symbol, which
+indicates to the C program that the sqrtl() routine is available.
+
+=item C<d_srand48_r>
+
+From F<d_srand48_r.U>:
+
+This variable conditionally defines the HAS_SRAND48_R symbol,
+which indicates to the C program that the srand48_r()
+routine is available.
+
+=item C<d_srandom_r>
+
+From F<d_srandom_r.U>:
+
+This variable conditionally defines the C<HAS_SRANDOM_R> symbol,
+which indicates to the C program that the srandom_r()
+routine is available.
+
+=item C<d_sresgproto>
+
+From F<d_sresgproto.U>:
+
+This variable conditionally defines the C<HAS_SETRESGID_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the setresgid() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_sresuproto>
+
+From F<d_sresuproto.U>:
+
+This variable conditionally defines the C<HAS_SETRESUID_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the setresuid() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_statblks>
+
+From F<d_statblks.U>:
+
+This variable conditionally defines C<USE_STAT_BLOCKS>
+if this system has a stat structure declaring
+st_blksize and st_blocks.
+
+=item C<d_statfs_f_flags>
+
+From F<d_statfs_f_flags.U>:
+
+This variable conditionally defines the C<HAS_STRUCT_STATFS_F_FLAGS>
+symbol, which indicates to struct statfs from has f_flags member.
+This kind of struct statfs is coming from F<sys/mount.h> (C<BSD>),
+not from F<sys/statfs.h> (C<SYSV>).
+
+=item C<d_statfs_s>
+
+From F<d_statfs_s.U>:
+
+This variable conditionally defines the C<HAS_STRUCT_STATFS> symbol,
+which indicates that the struct statfs is supported.
+
+=item C<d_statvfs>
+
+From F<d_statvfs.U>:
+
+This variable conditionally defines the C<HAS_STATVFS> symbol, which
+indicates to the C program that the statvfs() routine is available.
+
+=item C<d_stdio_cnt_lval>
+
+From F<d_stdstdio.U>:
+
+This variable conditionally defines C<STDIO_CNT_LVALUE> if the
+C<FILE_cnt> macro can be used as an lvalue.
+
+=item C<d_stdio_ptr_lval>
+
+From F<d_stdstdio.U>:
+
+This variable conditionally defines C<STDIO_PTR_LVALUE> if the
+C<FILE_ptr> macro can be used as an lvalue.
+
+=item C<d_stdio_ptr_lval_nochange_cnt>
+
+From F<d_stdstdio.U>:
+
+This symbol is defined if using the C<FILE_ptr> macro as an lvalue
+to increase the pointer by n leaves File_cnt(fp) unchanged.
+
+=item C<d_stdio_ptr_lval_sets_cnt>
+
+From F<d_stdstdio.U>:
+
+This symbol is defined if using the C<FILE_ptr> macro as an lvalue
+to increase the pointer by n has the side effect of decreasing the
+value of File_cnt(fp) by n.
+
+=item C<d_stdio_stream_array>
+
+From F<stdio_streams.U>:
+
+This variable tells whether there is an array holding
+the stdio streams.
+
+=item C<d_stdiobase>
+
+From F<d_stdstdio.U>:
+
+This variable conditionally defines C<USE_STDIO_BASE> if this system
+has a C<FILE> structure declaring a usable _base field (or equivalent)
+in F<stdio.h>.
+
+=item C<d_stdstdio>
+
+From F<d_stdstdio.U>:
+
+This variable conditionally defines C<USE_STDIO_PTR> if this system
+has a C<FILE> structure declaring usable _ptr and _cnt fields (or
+equivalent) in F<stdio.h>.
+
+=item C<d_strchr>
+
+From F<d_strchr.U>:
+
+This variable conditionally defines C<HAS_STRCHR> if strchr() and
+strrchr() are available for string searching.
+
+=item C<d_strcoll>
+
+From F<d_strcoll.U>:
+
+This variable conditionally defines C<HAS_STRCOLL> if strcoll() is
+available to compare strings using collating information.
+
+=item C<d_strctcpy>
+
+From F<d_strctcpy.U>:
+
+This variable conditionally defines the C<USE_STRUCT_COPY> symbol, which
+indicates to the C program that this C compiler knows how to copy
+structures.
+
+=item C<d_strerrm>
+
+From F<d_strerror.U>:
+
+This variable holds what Strerrr is defined as to translate an error
+code condition into an error message string. It could be C<strerror>
+or a more C<complex> macro emulating strrror with sys_errlist[], or the
+C<unknown> string when both strerror and sys_errlist are missing.
+
+=item C<d_strerror>
+
+From F<d_strerror.U>:
+
+This variable conditionally defines C<HAS_STRERROR> if strerror() is
+available to translate error numbers to strings.
+
+=item C<d_strerror_r>
+
+From F<d_strerror_r.U>:
+
+This variable conditionally defines the C<HAS_STRERROR_R> symbol,
+which indicates to the C program that the strerror_r()
+routine is available.
+
+=item C<d_strftime>
+
+From F<d_strftime.U>:
+
+This variable conditionally defines the C<HAS_STRFTIME> symbol, which
+indicates to the C program that the strftime() routine is available.
+
+=item C<d_strlcat>
+
+From F<d_strlcat.U>:
+
+This variable conditionally defines the C<HAS_STRLCAT> symbol, which
+indicates to the C program that the strlcat () routine is available.
+
+=item C<d_strlcpy>
+
+From F<d_strlcpy.U>:
+
+This variable conditionally defines the C<HAS_STRLCPY> symbol, which
+indicates to the C program that the strlcpy () routine is available.
+
+=item C<d_strtod>
+
+From F<d_strtod.U>:
+
+This variable conditionally defines the C<HAS_STRTOD> symbol, which
+indicates to the C program that the strtod() routine is available
+to provide better numeric string conversion than atof().
+
+=item C<d_strtol>
+
+From F<d_strtol.U>:
+
+This variable conditionally defines the C<HAS_STRTOL> symbol, which
+indicates to the C program that the strtol() routine is available
+to provide better numeric string conversion than atoi() and friends.
+
+=item C<d_strtold>
+
+From F<d_strtold.U>:
+
+This variable conditionally defines the C<HAS_STRTOLD> symbol, which
+indicates to the C program that the strtold() routine is available.
+
+=item C<d_strtoll>
+
+From F<d_strtoll.U>:
+
+This variable conditionally defines the C<HAS_STRTOLL> symbol, which
+indicates to the C program that the strtoll() routine is available.
+
+=item C<d_strtoq>
+
+From F<d_strtoq.U>:
+
+This variable conditionally defines the C<HAS_STRTOQ> symbol, which
+indicates to the C program that the strtoq() routine is available.
+
+=item C<d_strtoul>
+
+From F<d_strtoul.U>:
+
+This variable conditionally defines the C<HAS_STRTOUL> symbol, which
+indicates to the C program that the strtoul() routine is available
+to provide conversion of strings to unsigned long.
+
+=item C<d_strtoull>
+
+From F<d_strtoull.U>:
+
+This variable conditionally defines the C<HAS_STRTOULL> symbol, which
+indicates to the C program that the strtoull() routine is available.
+
+=item C<d_strtouq>
+
+From F<d_strtouq.U>:
+
+This variable conditionally defines the C<HAS_STRTOUQ> symbol, which
+indicates to the C program that the strtouq() routine is available.
+
+=item C<d_strxfrm>
+
+From F<d_strxfrm.U>:
+
+This variable conditionally defines C<HAS_STRXFRM> if strxfrm() is
+available to transform strings.
+
+=item C<d_suidsafe>
+
+From F<d_dosuid.U>:
+
+This variable conditionally defines C<SETUID_SCRIPTS_ARE_SECURE_NOW>
+if setuid scripts can be secure. This test looks in F</dev/fd/>.
+
+=item C<d_symlink>
+
+From F<d_symlink.U>:
+
+This variable conditionally defines the C<HAS_SYMLINK> symbol, which
+indicates to the C program that the symlink() routine is available
+to create symbolic links.
+
+=item C<d_syscall>
+
+From F<d_syscall.U>:
+
+This variable conditionally defines C<HAS_SYSCALL> if syscall() is
+available call arbitrary system calls.
+
+=item C<d_syscallproto>
+
+From F<d_syscallproto.U>:
+
+This variable conditionally defines the C<HAS_SYSCALL_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the syscall() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_sysconf>
+
+From F<d_sysconf.U>:
+
+This variable conditionally defines the C<HAS_SYSCONF> symbol, which
+indicates to the C program that the sysconf() routine is available
+to determine system related limits and options.
+
+=item C<d_sysernlst>
+
+From F<d_strerror.U>:
+
+This variable conditionally defines C<HAS_SYS_ERRNOLIST> if sys_errnolist[]
+is available to translate error numbers to the symbolic name.
+
+=item C<d_syserrlst>
+
+From F<d_strerror.U>:
+
+This variable conditionally defines C<HAS_SYS_ERRLIST> if sys_errlist[] is
+available to translate error numbers to strings.
+
+=item C<d_system>
+
+From F<d_system.U>:
+
+This variable conditionally defines C<HAS_SYSTEM> if system() is
+available to issue a shell command.
+
+=item C<d_tcgetpgrp>
+
+From F<d_tcgtpgrp.U>:
+
+This variable conditionally defines the C<HAS_TCGETPGRP> symbol, which
+indicates to the C program that the tcgetpgrp() routine is available.
+to get foreground process group C<ID>.
+
+=item C<d_tcsetpgrp>
+
+From F<d_tcstpgrp.U>:
+
+This variable conditionally defines the C<HAS_TCSETPGRP> symbol, which
+indicates to the C program that the tcsetpgrp() routine is available
+to set foreground process group C<ID>.
+
+=item C<d_telldir>
+
+From F<d_readdir.U>:
+
+This variable conditionally defines C<HAS_TELLDIR> if telldir() is
+available.
+
+=item C<d_telldirproto>
+
+From F<d_telldirproto.U>:
+
+This variable conditionally defines the C<HAS_TELLDIR_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the telldir() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_time>
+
+From F<d_time.U>:
+
+This variable conditionally defines the C<HAS_TIME> symbol, which indicates
+that the time() routine exists. The time() routine is normaly
+provided on C<UNIX> systems.
+
+=item C<d_timegm>
+
+From F<d_timegm.U>:
+
+This variable conditionally defines the C<HAS_TIMEGM> symbol, which
+indicates to the C program that the timegm () routine is available.
+
+=item C<d_times>
+
+From F<d_times.U>:
+
+This variable conditionally defines the C<HAS_TIMES> symbol, which indicates
+that the times() routine exists. The times() routine is normaly
+provided on C<UNIX> systems. You may have to include <sys/times.h>.
+
+=item C<d_tm_tm_gmtoff>
+
+From F<i_time.U>:
+
+This variable conditionally defines C<HAS_TM_TM_GMTOFF>, which indicates
+indicates to the C program that the struct tm has the tm_gmtoff field.
+
+=item C<d_tm_tm_zone>
+
+From F<i_time.U>:
+
+This variable conditionally defines C<HAS_TM_TM_ZONE>, which indicates
+indicates to the C program that the struct tm has the tm_zone field.
+
+=item C<d_tmpnam_r>
+
+From F<d_tmpnam_r.U>:
+
+This variable conditionally defines the C<HAS_TMPNAM_R> symbol,
+which indicates to the C program that the tmpnam_r()
+routine is available.
+
+=item C<d_truncate>
+
+From F<d_truncate.U>:
+
+This variable conditionally defines C<HAS_TRUNCATE> if truncate() is
+available to truncate files.
+
+=item C<d_ttyname_r>
+
+From F<d_ttyname_r.U>:
+
+This variable conditionally defines the C<HAS_TTYNAME_R> symbol,
+which indicates to the C program that the ttyname_r()
+routine is available.
+
+=item C<d_tzname>
+
+From F<d_tzname.U>:
+
+This variable conditionally defines C<HAS_TZNAME> if tzname[] is
+available to access timezone names.
+
+=item C<d_u32align>
+
+From F<d_u32align.U>:
+
+This variable tells whether you must access character data
+through U32-aligned pointers.
+
+=item C<d_ualarm>
+
+From F<d_ualarm.U>:
+
+This variable conditionally defines the C<HAS_UALARM> symbol, which
+indicates to the C program that the ualarm() routine is available.
+
+=item C<d_umask>
+
+From F<d_umask.U>:
+
+This variable conditionally defines the C<HAS_UMASK> symbol, which
+indicates to the C program that the umask() routine is available.
+to set and get the value of the file creation mask.
+
+=item C<d_uname>
+
+From F<d_gethname.U>:
+
+This variable conditionally defines the C<HAS_UNAME> symbol, which
+indicates to the C program that the uname() routine may be
+used to derive the host name.
+
+=item C<d_union_semun>
+
+From F<d_union_semun.U>:
+
+This variable conditionally defines C<HAS_UNION_SEMUN> if the
+union semun is defined by including <sys/sem.h>.
+
+=item C<d_unordered>
+
+From F<d_unordered.U>:
+
+This variable conditionally defines the C<HAS_UNORDERED> symbol, which
+indicates to the C program that the unordered() routine is available.
+
+=item C<d_unsetenv>
+
+From F<d_unsetenv.U>:
+
+This variable conditionally defines the C<HAS_UNSETENV> symbol, which
+indicates to the C program that the unsetenv () routine is available.
+
+=item C<d_usleep>
+
+From F<d_usleep.U>:
+
+This variable conditionally defines C<HAS_USLEEP> if usleep() is
+available to do high granularity sleeps.
+
+=item C<d_usleepproto>
+
+From F<d_usleepproto.U>:
+
+This variable conditionally defines the C<HAS_USLEEP_PROTO> symbol,
+which indicates to the C program that the system provides
+a prototype for the usleep() function. Otherwise, it is
+up to the program to supply one.
+
+=item C<d_ustat>
+
+From F<d_ustat.U>:
+
+This variable conditionally defines C<HAS_USTAT> if ustat() is
+available to query file system statistics by dev_t.
+
+=item C<d_vendorarch>
+
+From F<vendorarch.U>:
+
+This variable conditionally defined C<PERL_VENDORARCH>.
+
+=item C<d_vendorbin>
+
+From F<vendorbin.U>:
+
+This variable conditionally defines C<PERL_VENDORBIN>.
+
+=item C<d_vendorlib>
+
+From F<vendorlib.U>:
+
+This variable conditionally defines C<PERL_VENDORLIB>.
+
+=item C<d_vendorscript>
+
+From F<vendorscript.U>:
+
+This variable conditionally defines C<PERL_VENDORSCRIPT>.
+
+=item C<d_vfork>
+
+From F<d_vfork.U>:
+
+This variable conditionally defines the C<HAS_VFORK> symbol, which
+indicates the vfork() routine is available.
+
+=item C<d_void_closedir>
+
+From F<d_closedir.U>:
+
+This variable conditionally defines C<VOID_CLOSEDIR> if closedir()
+does not return a value.
+
+=item C<d_voidsig>
+
+From F<d_voidsig.U>:
+
+This variable conditionally defines C<VOIDSIG> if this system
+declares "void (*signal(...))()" in F<signal.h>. The old way was to
+declare it as "int (*signal(...))()".
+
+=item C<d_voidtty>
+
+From F<i_sysioctl.U>:
+
+This variable conditionally defines C<USE_IOCNOTTY> to indicate that the
+ioctl() call with C<TIOCNOTTY> should be used to void tty association.
+Otherwise (on C<USG> probably), it is enough to close the standard file
+decriptors and do a setpgrp().
+
+=item C<d_volatile>
+
+From F<d_volatile.U>:
+
+This variable conditionally defines the C<HASVOLATILE> symbol, which
+indicates to the C program that this C compiler knows about the
+volatile declaration.
+
+=item C<d_vprintf>
+
+From F<d_vprintf.U>:
+
+This variable conditionally defines the C<HAS_VPRINTF> symbol, which
+indicates to the C program that the vprintf() routine is available
+to printf with a pointer to an argument list.
+
+=item C<d_vsnprintf>
+
+From F<d_snprintf.U>:
+
+This variable conditionally defines the C<HAS_VSNPRINTF> symbol, which
+indicates to the C program that the vsnprintf () library function
+is available.
+
+=item C<d_wait4>
+
+From F<d_wait4.U>:
+
+This variable conditionally defines the HAS_WAIT4 symbol, which
+indicates the wait4() routine is available.
+
+=item C<d_waitpid>
+
+From F<d_waitpid.U>:
+
+This variable conditionally defines C<HAS_WAITPID> if waitpid() is
+available to wait for child process.
+
+=item C<d_wcstombs>
+
+From F<d_wcstombs.U>:
+
+This variable conditionally defines the C<HAS_WCSTOMBS> symbol, which
+indicates to the C program that the wcstombs() routine is available
+to convert wide character strings to multibyte strings.
+
+=item C<d_wctomb>
+
+From F<d_wctomb.U>:
+
+This variable conditionally defines the C<HAS_WCTOMB> symbol, which
+indicates to the C program that the wctomb() routine is available
+to convert a wide character to a multibyte.
+
+=item C<d_writev>
+
+From F<d_writev.U>:
+
+This variable conditionally defines the C<HAS_WRITEV> symbol, which
+indicates to the C program that the writev() routine is available.
+
+=item C<d_xenix>
+
+From F<Guess.U>:
+
+This variable conditionally defines the symbol C<XENIX>, which alerts
+the C program that it runs under Xenix.
+
+=item C<date>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the date program. After Configure runs,
+the value is reset to a plain C<date> and is not useful.
+
+=item C<db_hashtype>
+
+From F<i_db.U>:
+
+This variable contains the type of the hash structure element
+in the <db.h> header file. In older versions of C<DB>, it was
+int, while in newer ones it is u_int32_t.
+
+=item C<db_prefixtype>
+
+From F<i_db.U>:
+
+This variable contains the type of the prefix structure element
+in the <db.h> header file. In older versions of C<DB>, it was
+int, while in newer ones it is size_t.
+
+=item C<db_version_major>
+
+From F<i_db.U>:
+
+This variable contains the major version number of
+Berkeley C<DB> found in the <db.h> header file.
+
+=item C<db_version_minor>
+
+From F<i_db.U>:
+
+This variable contains the minor version number of
+Berkeley C<DB> found in the <db.h> header file.
+For C<DB> version 1 this is always 0.
+
+=item C<db_version_patch>
+
+From F<i_db.U>:
+
+This variable contains the patch version number of
+Berkeley C<DB> found in the <db.h> header file.
+For C<DB> version 1 this is always 0.
+
+=item C<defvoidused>
+
+From F<voidflags.U>:
+
+This variable contains the default value of the C<VOIDUSED> symbol (15).
+
+=item C<direntrytype>
+
+From F<i_dirent.U>:
+
+This symbol is set to C<struct direct> or C<struct dirent> depending on
+whether dirent is available or not. You should use this pseudo type to
+portably declare your directory entries.
+
+=item C<dlext>
+
+From F<dlext.U>:
+
+This variable contains the extension that is to be used for the
+dynamically loaded modules that perl generaties.
+
+=item C<dlsrc>
+
+From F<dlsrc.U>:
+
+This variable contains the name of the dynamic loading file that
+will be used with the package.
+
+=item C<doublesize>
+
+From F<doublesize.U>:
+
+This variable contains the value of the C<DOUBLESIZE> symbol, which
+indicates to the C program how many bytes there are in a double.
+
+=item C<drand01>
+
+From F<randfunc.U>:
+
+Indicates the macro to be used to generate normalized
+random numbers. Uses randfunc, often divided by
+(double) (((unsigned long) 1 << randbits)) in order to
+normalize the result.
+In C programs, the macro C<Drand01> is mapped to drand01.
+
+=item C<drand48_r_proto>
+
+From F<d_drand48_r.U>:
+
+This variable encodes the prototype of drand48_r.
+It is zero if d_drand48_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_drand48_r
+is defined.
+
+=item C<dtrace>
+
+From F<usedtrace.U>:
+
+This variable holds the location of the dtrace executable.
+
+=item C<dynamic_ext>
+
+From F<Extensions.U>:
+
+This variable holds a list of C<XS> extension files we want to
+link dynamically into the package. It is used by Makefile.
+
+=back
+
+=cut
+
+=head2 e
+
+=over 4
+
+=cut
+
+=item C<eagain>
+
+From F<nblock_io.U>:
+
+This variable bears the symbolic errno code set by read() when no
+data is present on the file and non-blocking I/O was enabled (otherwise,
+read() blocks naturally).
+
+=item C<ebcdic>
+
+From F<ebcdic.U>:
+
+This variable conditionally defines C<EBCDIC> if this
+system uses C<EBCDIC> encoding. Among other things, this
+means that the character ranges are not contiguous.
+See F<trnl.U>
+
+=item C<echo>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the echo program. After Configure runs,
+the value is reset to a plain C<echo> and is not useful.
+
+=item C<egrep>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the egrep program. After Configure runs,
+the value is reset to a plain C<egrep> and is not useful.
+
+=item C<emacs>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<endgrent_r_proto>
+
+From F<d_endgrent_r.U>:
+
+This variable encodes the prototype of endgrent_r.
+It is zero if d_endgrent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_endgrent_r
+is defined.
+
+=item C<endhostent_r_proto>
+
+From F<d_endhostent_r.U>:
+
+This variable encodes the prototype of endhostent_r.
+It is zero if d_endhostent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_endhostent_r
+is defined.
+
+=item C<endnetent_r_proto>
+
+From F<d_endnetent_r.U>:
+
+This variable encodes the prototype of endnetent_r.
+It is zero if d_endnetent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_endnetent_r
+is defined.
+
+=item C<endprotoent_r_proto>
+
+From F<d_endprotoent_r.U>:
+
+This variable encodes the prototype of endprotoent_r.
+It is zero if d_endprotoent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_endprotoent_r
+is defined.
+
+=item C<endpwent_r_proto>
+
+From F<d_endpwent_r.U>:
+
+This variable encodes the prototype of endpwent_r.
+It is zero if d_endpwent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_endpwent_r
+is defined.
+
+=item C<endservent_r_proto>
+
+From F<d_endservent_r.U>:
+
+This variable encodes the prototype of endservent_r.
+It is zero if d_endservent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_endservent_r
+is defined.
+
+=item C<eunicefix>
+
+From F<Init.U>:
+
+When running under Eunice this variable contains a command which will
+convert a shell script to the proper form of text file for it to be
+executable by the shell. On other systems it is a no-op.
+
+=item C<exe_ext>
+
+From F<Unix.U>:
+
+This is an old synonym for _exe.
+
+=item C<expr>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the expr program. After Configure runs,
+the value is reset to a plain C<expr> and is not useful.
+
+=item C<extensions>
+
+From F<Extensions.U>:
+
+This variable holds a list of all extension files (both C<XS> and
+non-xs linked into the package. It is propagated to F<Config.pm>
+and is typically used to test whether a particular extesion
+is available.
+
+=item C<extern_C>
+
+From F<Csym.U>:
+
+C<ANSI> C requires C<extern> where C++ requires 'extern C<C>'. This
+variable can be used in Configure to do the right thing.
+
+=item C<extras>
+
+From F<Extras.U>:
+
+This variable holds a list of extra modules to install.
+
+=back
+
+=cut
+
+=head2 f
+
+=over 4
+
+=cut
+
+=item C<fflushall>
+
+From F<fflushall.U>:
+
+This symbol, if defined, tells that to flush
+all pending stdio output one must loop through all
+the stdio file handles stored in an array and fflush them.
+Note that if fflushNULL is defined, fflushall will not
+even be probed for and will be left undefined.
+
+=item C<fflushNULL>
+
+From F<fflushall.U>:
+
+This symbol, if defined, tells that fflush(C<NULL>) does flush
+all pending stdio output.
+
+=item C<find>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<firstmakefile>
+
+From F<Unix.U>:
+
+This variable defines the first file searched by make. On unix,
+it is makefile (then Makefile). On case-insensitive systems,
+it might be something else. This is only used to deal with
+convoluted make depend tricks.
+
+=item C<flex>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<fpossize>
+
+From F<fpossize.U>:
+
+This variable contains the size of a fpostype in bytes.
+
+=item C<fpostype>
+
+From F<fpostype.U>:
+
+This variable defines Fpos_t to be something like fpos_t, long,
+uint, or whatever type is used to declare file positions in libc.
+
+=item C<freetype>
+
+From F<mallocsrc.U>:
+
+This variable contains the return type of free(). It is usually
+void, but occasionally int.
+
+=item C<from>
+
+From F<Cross.U>:
+
+This variable contains the command used by Configure
+to copy files from the target host. Useful and available
+only during Perl build.
+The string C<:> if not cross-compiling.
+
+=item C<full_ar>
+
+From F<Loc_ar.U>:
+
+This variable contains the full pathname to C<ar>, whether or
+not the user has specified C<portability>. This is only used
+in the F<Makefile.SH>.
+
+=item C<full_csh>
+
+From F<d_csh.U>:
+
+This variable contains the full pathname to C<csh>, whether or
+not the user has specified C<portability>. This is only used
+in the compiled C program, and we assume that all systems which
+can share this executable will have the same full pathname to
+F<csh.>
+
+=item C<full_sed>
+
+From F<Loc_sed.U>:
+
+This variable contains the full pathname to C<sed>, whether or
+not the user has specified C<portability>. This is only used
+in the compiled C program, and we assume that all systems which
+can share this executable will have the same full pathname to
+F<sed.>
+
+=back
+
+=cut
+
+=head2 g
+
+=over 4
+
+=cut
+
+=item C<gccansipedantic>
+
+From F<gccvers.U>:
+
+If C<GNU> cc (gcc) is used, this variable will enable (if set) the
+-ansi and -pedantic ccflags for building core files (through
+cflags script). (See F<Porting/pumpkin.pod> for full description).
+
+=item C<gccosandvers>
+
+From F<gccvers.U>:
+
+If C<GNU> cc (gcc) is used, this variable holds the operating system
+and version used to compile gcc. It is set to '' if not gcc,
+or if nothing useful can be parsed as the os version.
+
+=item C<gccversion>
+
+From F<gccvers.U>:
+
+If C<GNU> cc (gcc) is used, this variable holds C<1> or C<2> to
+indicate whether the compiler is version 1 or 2. This is used in
+setting some of the default cflags. It is set to '' if not gcc.
+
+=item C<getgrent_r_proto>
+
+From F<d_getgrent_r.U>:
+
+This variable encodes the prototype of getgrent_r.
+It is zero if d_getgrent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getgrent_r
+is defined.
+
+=item C<getgrgid_r_proto>
+
+From F<d_getgrgid_r.U>:
+
+This variable encodes the prototype of getgrgid_r.
+It is zero if d_getgrgid_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getgrgid_r
+is defined.
+
+=item C<getgrnam_r_proto>
+
+From F<d_getgrnam_r.U>:
+
+This variable encodes the prototype of getgrnam_r.
+It is zero if d_getgrnam_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getgrnam_r
+is defined.
+
+=item C<gethostbyaddr_r_proto>
+
+From F<d_gethostbyaddr_r.U>:
+
+This variable encodes the prototype of gethostbyaddr_r.
+It is zero if d_gethostbyaddr_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_gethostbyaddr_r
+is defined.
+
+=item C<gethostbyname_r_proto>
+
+From F<d_gethostbyname_r.U>:
+
+This variable encodes the prototype of gethostbyname_r.
+It is zero if d_gethostbyname_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_gethostbyname_r
+is defined.
+
+=item C<gethostent_r_proto>
+
+From F<d_gethostent_r.U>:
+
+This variable encodes the prototype of gethostent_r.
+It is zero if d_gethostent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_gethostent_r
+is defined.
+
+=item C<getlogin_r_proto>
+
+From F<d_getlogin_r.U>:
+
+This variable encodes the prototype of getlogin_r.
+It is zero if d_getlogin_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getlogin_r
+is defined.
+
+=item C<getnetbyaddr_r_proto>
+
+From F<d_getnetbyaddr_r.U>:
+
+This variable encodes the prototype of getnetbyaddr_r.
+It is zero if d_getnetbyaddr_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getnetbyaddr_r
+is defined.
+
+=item C<getnetbyname_r_proto>
+
+From F<d_getnetbyname_r.U>:
+
+This variable encodes the prototype of getnetbyname_r.
+It is zero if d_getnetbyname_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getnetbyname_r
+is defined.
+
+=item C<getnetent_r_proto>
+
+From F<d_getnetent_r.U>:
+
+This variable encodes the prototype of getnetent_r.
+It is zero if d_getnetent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getnetent_r
+is defined.
+
+=item C<getprotobyname_r_proto>
+
+From F<d_getprotobyname_r.U>:
+
+This variable encodes the prototype of getprotobyname_r.
+It is zero if d_getprotobyname_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getprotobyname_r
+is defined.
+
+=item C<getprotobynumber_r_proto>
+
+From F<d_getprotobynumber_r.U>:
+
+This variable encodes the prototype of getprotobynumber_r.
+It is zero if d_getprotobynumber_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getprotobynumber_r
+is defined.
+
+=item C<getprotoent_r_proto>
+
+From F<d_getprotoent_r.U>:
+
+This variable encodes the prototype of getprotoent_r.
+It is zero if d_getprotoent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getprotoent_r
+is defined.
+
+=item C<getpwent_r_proto>
+
+From F<d_getpwent_r.U>:
+
+This variable encodes the prototype of getpwent_r.
+It is zero if d_getpwent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getpwent_r
+is defined.
+
+=item C<getpwnam_r_proto>
+
+From F<d_getpwnam_r.U>:
+
+This variable encodes the prototype of getpwnam_r.
+It is zero if d_getpwnam_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getpwnam_r
+is defined.
+
+=item C<getpwuid_r_proto>
+
+From F<d_getpwuid_r.U>:
+
+This variable encodes the prototype of getpwuid_r.
+It is zero if d_getpwuid_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getpwuid_r
+is defined.
+
+=item C<getservbyname_r_proto>
+
+From F<d_getservbyname_r.U>:
+
+This variable encodes the prototype of getservbyname_r.
+It is zero if d_getservbyname_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getservbyname_r
+is defined.
+
+=item C<getservbyport_r_proto>
+
+From F<d_getservbyport_r.U>:
+
+This variable encodes the prototype of getservbyport_r.
+It is zero if d_getservbyport_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getservbyport_r
+is defined.
+
+=item C<getservent_r_proto>
+
+From F<d_getservent_r.U>:
+
+This variable encodes the prototype of getservent_r.
+It is zero if d_getservent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getservent_r
+is defined.
+
+=item C<getspnam_r_proto>
+
+From F<d_getspnam_r.U>:
+
+This variable encodes the prototype of getspnam_r.
+It is zero if d_getspnam_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_getspnam_r
+is defined.
+
+=item C<gidformat>
+
+From F<gidf.U>:
+
+This variable contains the format string used for printing a Gid_t.
+
+=item C<gidsign>
+
+From F<gidsign.U>:
+
+This variable contains the signedness of a gidtype.
+1 for unsigned, -1 for signed.
+
+=item C<gidsize>
+
+From F<gidsize.U>:
+
+This variable contains the size of a gidtype in bytes.
+
+=item C<gidtype>
+
+From F<gidtype.U>:
+
+This variable defines Gid_t to be something like gid_t, int,
+ushort, or whatever type is used to declare the return type
+of getgid(). Typically, it is the type of group ids in the kernel.
+
+=item C<glibpth>
+
+From F<libpth.U>:
+
+This variable holds the general path (space-separated) used to
+find libraries. It may contain directories that do not exist on
+this platform, libpth is the cleaned-up version.
+
+=item C<gmake>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the gmake program. After Configure runs,
+the value is reset to a plain C<gmake> and is not useful.
+
+=item C<gmtime_r_proto>
+
+From F<d_gmtime_r.U>:
+
+This variable encodes the prototype of gmtime_r.
+It is zero if d_gmtime_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_gmtime_r
+is defined.
+
+=item C<gnulibc_version>
+
+From F<d_gnulibc.U>:
+
+This variable contains the version number of the C<GNU> C library.
+It is usually something like F<2.2.5>. It is a plain '' if this
+is not the C<GNU> C library, or if the version is unknown.
+
+=item C<grep>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the grep program. After Configure runs,
+the value is reset to a plain C<grep> and is not useful.
+
+=item C<groupcat>
+
+From F<nis.U>:
+
+This variable contains a command that produces the text of the
+F</etc/group> file. This is normally "cat F</etc/group>", but can be
+"ypcat group" when C<NIS> is used.
+On some systems, such as os390, there may be no equivalent
+command, in which case this variable is unset.
+
+=item C<groupstype>
+
+From F<groupstype.U>:
+
+This variable defines Groups_t to be something like gid_t, int,
+ushort, or whatever type is used for the second argument to
+getgroups() and setgroups(). Usually, this is the same as
+gidtype (gid_t), but sometimes it isn't.
+
+=item C<gzip>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the gzip program. After Configure runs,
+the value is reset to a plain C<gzip> and is not useful.
+
+=back
+
+=cut
+
+=head2 h
+
+=over 4
+
+=cut
+
+=item C<h_fcntl>
+
+From F<h_fcntl.U>:
+
+This is variable gets set in various places to tell i_fcntl that
+<fcntl.h> should be included.
+
+=item C<h_sysfile>
+
+From F<h_sysfile.U>:
+
+This is variable gets set in various places to tell i_sys_file that
+<sys/file.h> should be included.
+
+=item C<hint>
+
+From F<Oldconfig.U>:
+
+Gives the type of hints used for previous answers. May be one of
+C<default>, C<recommended> or C<previous>.
+
+=item C<hostcat>
+
+From F<nis.U>:
+
+This variable contains a command that produces the text of the
+F</etc/hosts> file. This is normally "cat F</etc/hosts>", but can be
+"ypcat hosts" when C<NIS> is used.
+On some systems, such as os390, there may be no equivalent
+command, in which case this variable is unset.
+
+=item C<html1dir>
+
+From F<html1dir.U>:
+
+This variable contains the name of the directory in which html
+source pages are to be put. This directory is for pages
+that describe whole programs, not libraries or modules. It
+is intended to correspond roughly to section 1 of the Unix
+manuals.
+
+=item C<html1direxp>
+
+From F<html1dir.U>:
+
+This variable is the same as the html1dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<html3dir>
+
+From F<html3dir.U>:
+
+This variable contains the name of the directory in which html
+source pages are to be put. This directory is for pages
+that describe libraries or modules. It is intended to
+correspond roughly to section 3 of the Unix manuals.
+
+=item C<html3direxp>
+
+From F<html3dir.U>:
+
+This variable is the same as the html3dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=back
+
+=cut
+
+=head2 i
+
+=over 4
+
+=cut
+
+=item C<i16size>
+
+From F<perlxv.U>:
+
+This variable is the size of an I16 in bytes.
+
+=item C<i16type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's I16.
+
+=item C<i32size>
+
+From F<perlxv.U>:
+
+This variable is the size of an I32 in bytes.
+
+=item C<i32type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's I32.
+
+=item C<i64size>
+
+From F<perlxv.U>:
+
+This variable is the size of an I64 in bytes.
+
+=item C<i64type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's I64.
+
+=item C<i8size>
+
+From F<perlxv.U>:
+
+This variable is the size of an I8 in bytes.
+
+=item C<i8type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's I8.
+
+=item C<i_arpainet>
+
+From F<i_arpainet.U>:
+
+This variable conditionally defines the C<I_ARPA_INET> symbol,
+and indicates whether a C program should include <arpa/inet.h>.
+
+=item C<i_assert>
+
+From F<i_assert.U>:
+
+This variable conditionally defines the C<I_ASSERT> symbol, which
+indicates to the C program that <assert.h> exists and could be
+included.
+
+=item C<i_bsdioctl>
+
+From F<i_sysioctl.U>:
+
+This variable conditionally defines the C<I_SYS_BSDIOCTL> symbol, which
+indicates to the C program that <sys/bsdioctl.h> exists and should
+be included.
+
+=item C<i_crypt>
+
+From F<i_crypt.U>:
+
+This variable conditionally defines the C<I_CRYPT> symbol, and indicates
+whether a C program should include <crypt.h>.
+
+=item C<i_db>
+
+From F<i_db.U>:
+
+This variable conditionally defines the C<I_DB> symbol, and indicates
+whether a C program may include Berkeley's C<DB> include file <db.h>.
+
+=item C<i_dbm>
+
+From F<i_dbm.U>:
+
+This variable conditionally defines the C<I_DBM> symbol, which
+indicates to the C program that <dbm.h> exists and should
+be included.
+
+=item C<i_dirent>
+
+From F<i_dirent.U>:
+
+This variable conditionally defines C<I_DIRENT>, which indicates
+to the C program that it should include <dirent.h>.
+
+=item C<i_dld>
+
+From F<i_dld.U>:
+
+This variable conditionally defines the C<I_DLD> symbol, which
+indicates to the C program that <dld.h> (C<GNU> dynamic loading)
+exists and should be included.
+
+=item C<i_dlfcn>
+
+From F<i_dlfcn.U>:
+
+This variable conditionally defines the C<I_DLFCN> symbol, which
+indicates to the C program that <dlfcn.h> exists and should
+be included.
+
+=item C<i_fcntl>
+
+From F<i_fcntl.U>:
+
+This variable controls the value of C<I_FCNTL> (which tells
+the C program to include <fcntl.h>).
+
+=item C<i_float>
+
+From F<i_float.U>:
+
+This variable conditionally defines the C<I_FLOAT> symbol, and indicates
+whether a C program may include <float.h> to get symbols like C<DBL_MAX>
+or C<DBL_MIN>, F<i.e>. machine dependent floating point values.
+
+=item C<i_fp>
+
+From F<i_fp.U>:
+
+This variable conditionally defines the C<I_FP> symbol, and indicates
+whether a C program should include <fp.h>.
+
+=item C<i_fp_class>
+
+From F<i_fp_class.U>:
+
+This variable conditionally defines the C<I_FP_CLASS> symbol, and indicates
+whether a C program should include <fp_class.h>.
+
+=item C<i_gdbm>
+
+From F<i_gdbm.U>:
+
+This variable conditionally defines the C<I_GDBM> symbol, which
+indicates to the C program that <gdbm.h> exists and should
+be included.
+
+=item C<i_gdbm_ndbm>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<I_GDBM_NDBM> symbol, which
+indicates to the C program that <gdbm-F<ndbm.h>> exists and should
+be included. This is the location of the F<ndbm.h> compatibility file
+in Debian 4.0.
+
+=item C<i_gdbmndbm>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<I_GDBMNDBM> symbol, which
+indicates to the C program that <gdbm/ndbm.h> exists and should
+be included. This was the location of the F<ndbm.h> compatibility file
+in RedHat 7.1.
+
+=item C<i_grp>
+
+From F<i_grp.U>:
+
+This variable conditionally defines the C<I_GRP> symbol, and indicates
+whether a C program should include <grp.h>.
+
+=item C<i_ieeefp>
+
+From F<i_ieeefp.U>:
+
+This variable conditionally defines the C<I_IEEEFP> symbol, and indicates
+whether a C program should include <ieeefp.h>.
+
+=item C<i_inttypes>
+
+From F<i_inttypes.U>:
+
+This variable conditionally defines the C<I_INTTYPES> symbol,
+and indicates whether a C program should include <inttypes.h>.
+
+=item C<i_langinfo>
+
+From F<i_langinfo.U>:
+
+This variable conditionally defines the C<I_LANGINFO> symbol,
+and indicates whether a C program should include <langinfo.h>.
+
+=item C<i_libutil>
+
+From F<i_libutil.U>:
+
+This variable conditionally defines the C<I_LIBUTIL> symbol, and indicates
+whether a C program should include <libutil.h>.
+
+=item C<i_limits>
+
+From F<i_limits.U>:
+
+This variable conditionally defines the C<I_LIMITS> symbol, and indicates
+whether a C program may include <limits.h> to get symbols like C<WORD_BIT>
+and friends.
+
+=item C<i_locale>
+
+From F<i_locale.U>:
+
+This variable conditionally defines the C<I_LOCALE> symbol,
+and indicates whether a C program should include <locale.h>.
+
+=item C<i_machcthr>
+
+From F<i_machcthr.U>:
+
+This variable conditionally defines the C<I_MACH_CTHREADS> symbol,
+and indicates whether a C program should include <mach/cthreads.h>.
+
+=item C<i_malloc>
+
+From F<i_malloc.U>:
+
+This variable conditionally defines the C<I_MALLOC> symbol, and indicates
+whether a C program should include <malloc.h>.
+
+=item C<i_mallocmalloc>
+
+From F<i_mallocmalloc.U>:
+
+This variable conditionally defines the C<I_MALLOCMALLOC> symbol,
+and indicates whether a C program should include <malloc/malloc.h>.
+
+=item C<i_math>
+
+From F<i_math.U>:
+
+This variable conditionally defines the C<I_MATH> symbol, and indicates
+whether a C program may include <math.h>.
+
+=item C<i_memory>
+
+From F<i_memory.U>:
+
+This variable conditionally defines the C<I_MEMORY> symbol, and indicates
+whether a C program should include <memory.h>.
+
+=item C<i_mntent>
+
+From F<i_mntent.U>:
+
+This variable conditionally defines the C<I_MNTENT> symbol, and indicates
+whether a C program should include <mntent.h>.
+
+=item C<i_ndbm>
+
+From F<i_ndbm.U>:
+
+This variable conditionally defines the C<I_NDBM> symbol, which
+indicates to the C program that <ndbm.h> exists and should
+be included.
+
+=item C<i_netdb>
+
+From F<i_netdb.U>:
+
+This variable conditionally defines the C<I_NETDB> symbol, and indicates
+whether a C program should include <netdb.h>.
+
+=item C<i_neterrno>
+
+From F<i_neterrno.U>:
+
+This variable conditionally defines the C<I_NET_ERRNO> symbol, which
+indicates to the C program that <net/errno.h> exists and should
+be included.
+
+=item C<i_netinettcp>
+
+From F<i_netinettcp.U>:
+
+This variable conditionally defines the C<I_NETINET_TCP> symbol,
+and indicates whether a C program should include <netinet/tcp.h>.
+
+=item C<i_niin>
+
+From F<i_niin.U>:
+
+This variable conditionally defines C<I_NETINET_IN>, which indicates
+to the C program that it should include <netinet/in.h>. Otherwise,
+you may try <sys/in.h>.
+
+=item C<i_poll>
+
+From F<i_poll.U>:
+
+This variable conditionally defines the C<I_POLL> symbol, and indicates
+whether a C program should include <poll.h>.
+
+=item C<i_prot>
+
+From F<i_prot.U>:
+
+This variable conditionally defines the C<I_PROT> symbol, and indicates
+whether a C program should include <prot.h>.
+
+=item C<i_pthread>
+
+From F<i_pthread.U>:
+
+This variable conditionally defines the C<I_PTHREAD> symbol,
+and indicates whether a C program should include <pthread.h>.
+
+=item C<i_pwd>
+
+From F<i_pwd.U>:
+
+This variable conditionally defines C<I_PWD>, which indicates
+to the C program that it should include <pwd.h>.
+
+=item C<i_rpcsvcdbm>
+
+From F<i_dbm.U>:
+
+This variable conditionally defines the C<I_RPCSVC_DBM> symbol, which
+indicates to the C program that <rpcsvc/dbm.h> exists and should
+be included. Some System V systems might need this instead of <dbm.h>.
+
+=item C<i_sfio>
+
+From F<i_sfio.U>:
+
+This variable conditionally defines the C<I_SFIO> symbol,
+and indicates whether a C program should include <sfio.h>.
+
+=item C<i_sgtty>
+
+From F<i_termio.U>:
+
+This variable conditionally defines the C<I_SGTTY> symbol, which
+indicates to the C program that it should include <sgtty.h> rather
+than <termio.h>.
+
+=item C<i_shadow>
+
+From F<i_shadow.U>:
+
+This variable conditionally defines the C<I_SHADOW> symbol, and indicates
+whether a C program should include <shadow.h>.
+
+=item C<i_socks>
+
+From F<i_socks.U>:
+
+This variable conditionally defines the C<I_SOCKS> symbol, and indicates
+whether a C program should include <socks.h>.
+
+=item C<i_stdarg>
+
+From F<i_varhdr.U>:
+
+This variable conditionally defines the C<I_STDARG> symbol, which
+indicates to the C program that <stdarg.h> exists and should
+be included.
+
+=item C<i_stddef>
+
+From F<i_stddef.U>:
+
+This variable conditionally defines the C<I_STDDEF> symbol, which
+indicates to the C program that <stddef.h> exists and should
+be included.
+
+=item C<i_stdlib>
+
+From F<i_stdlib.U>:
+
+This variable conditionally defines the C<I_STDLIB> symbol, which
+indicates to the C program that <stdlib.h> exists and should
+be included.
+
+=item C<i_string>
+
+From F<i_string.U>:
+
+This variable conditionally defines the C<I_STRING> symbol, which
+indicates that <string.h> should be included rather than <strings.h>.
+
+=item C<i_sunmath>
+
+From F<i_sunmath.U>:
+
+This variable conditionally defines the C<I_SUNMATH> symbol, and indicates
+whether a C program should include <sunmath.h>.
+
+=item C<i_sysaccess>
+
+From F<i_sysaccess.U>:
+
+This variable conditionally defines the C<I_SYS_ACCESS> symbol,
+and indicates whether a C program should include <sys/access.h>.
+
+=item C<i_sysdir>
+
+From F<i_sysdir.U>:
+
+This variable conditionally defines the C<I_SYS_DIR> symbol, and indicates
+whether a C program should include <sys/dir.h>.
+
+=item C<i_sysfile>
+
+From F<i_sysfile.U>:
+
+This variable conditionally defines the C<I_SYS_FILE> symbol, and indicates
+whether a C program should include <sys/file.h> to get C<R_OK> and friends.
+
+=item C<i_sysfilio>
+
+From F<i_sysioctl.U>:
+
+This variable conditionally defines the C<I_SYS_FILIO> symbol, which
+indicates to the C program that <sys/filio.h> exists and should
+be included in preference to <sys/ioctl.h>.
+
+=item C<i_sysin>
+
+From F<i_niin.U>:
+
+This variable conditionally defines C<I_SYS_IN>, which indicates
+to the C program that it should include <sys/in.h> instead of
+<netinet/in.h>.
+
+=item C<i_sysioctl>
+
+From F<i_sysioctl.U>:
+
+This variable conditionally defines the C<I_SYS_IOCTL> symbol, which
+indicates to the C program that <sys/ioctl.h> exists and should
+be included.
+
+=item C<i_syslog>
+
+From F<i_syslog.U>:
+
+This variable conditionally defines the C<I_SYSLOG> symbol,
+and indicates whether a C program should include <syslog.h>.
+
+=item C<i_sysmman>
+
+From F<i_sysmman.U>:
+
+This variable conditionally defines the C<I_SYS_MMAN> symbol, and
+indicates whether a C program should include <sys/mman.h>.
+
+=item C<i_sysmode>
+
+From F<i_sysmode.U>:
+
+This variable conditionally defines the C<I_SYSMODE> symbol,
+and indicates whether a C program should include <sys/mode.h>.
+
+=item C<i_sysmount>
+
+From F<i_sysmount.U>:
+
+This variable conditionally defines the C<I_SYSMOUNT> symbol,
+and indicates whether a C program should include <sys/mount.h>.
+
+=item C<i_sysndir>
+
+From F<i_sysndir.U>:
+
+This variable conditionally defines the C<I_SYS_NDIR> symbol, and indicates
+whether a C program should include <sys/ndir.h>.
+
+=item C<i_sysparam>
+
+From F<i_sysparam.U>:
+
+This variable conditionally defines the C<I_SYS_PARAM> symbol, and indicates
+whether a C program should include <sys/param.h>.
+
+=item C<i_syspoll>
+
+From F<i_syspoll.U>:
+
+This variable conditionally defines the C<I_SYS_POLL> symbol, which
+indicates to the C program that it should include <sys/poll.h>.
+
+=item C<i_sysresrc>
+
+From F<i_sysresrc.U>:
+
+This variable conditionally defines the C<I_SYS_RESOURCE> symbol,
+and indicates whether a C program should include <sys/resource.h>.
+
+=item C<i_syssecrt>
+
+From F<i_syssecrt.U>:
+
+This variable conditionally defines the C<I_SYS_SECURITY> symbol,
+and indicates whether a C program should include <sys/security.h>.
+
+=item C<i_sysselct>
+
+From F<i_sysselct.U>:
+
+This variable conditionally defines C<I_SYS_SELECT>, which indicates
+to the C program that it should include <sys/select.h> in order to
+get the definition of struct timeval.
+
+=item C<i_syssockio>
+
+From F<i_sysioctl.U>:
+
+This variable conditionally defines C<I_SYS_SOCKIO> to indicate to the
+C program that socket ioctl codes may be found in <sys/sockio.h>
+instead of <sys/ioctl.h>.
+
+=item C<i_sysstat>
+
+From F<i_sysstat.U>:
+
+This variable conditionally defines the C<I_SYS_STAT> symbol,
+and indicates whether a C program should include <sys/stat.h>.
+
+=item C<i_sysstatfs>
+
+From F<i_sysstatfs.U>:
+
+This variable conditionally defines the C<I_SYSSTATFS> symbol,
+and indicates whether a C program should include <sys/statfs.h>.
+
+=item C<i_sysstatvfs>
+
+From F<i_sysstatvfs.U>:
+
+This variable conditionally defines the C<I_SYSSTATVFS> symbol,
+and indicates whether a C program should include <sys/statvfs.h>.
+
+=item C<i_systime>
+
+From F<i_time.U>:
+
+This variable conditionally defines C<I_SYS_TIME>, which indicates
+to the C program that it should include <sys/time.h>.
+
+=item C<i_systimek>
+
+From F<i_time.U>:
+
+This variable conditionally defines C<I_SYS_TIME_KERNEL>, which
+indicates to the C program that it should include <sys/time.h>
+with C<KERNEL> defined.
+
+=item C<i_systimes>
+
+From F<i_systimes.U>:
+
+This variable conditionally defines the C<I_SYS_TIMES> symbol, and indicates
+whether a C program should include <sys/times.h>.
+
+=item C<i_systypes>
+
+From F<i_systypes.U>:
+
+This variable conditionally defines the C<I_SYS_TYPES> symbol,
+and indicates whether a C program should include <sys/types.h>.
+
+=item C<i_sysuio>
+
+From F<i_sysuio.U>:
+
+This variable conditionally defines the C<I_SYSUIO> symbol, and indicates
+whether a C program should include <sys/uio.h>.
+
+=item C<i_sysun>
+
+From F<i_sysun.U>:
+
+This variable conditionally defines C<I_SYS_UN>, which indicates
+to the C program that it should include <sys/un.h> to get C<UNIX>
+domain socket definitions.
+
+=item C<i_sysutsname>
+
+From F<i_sysutsname.U>:
+
+This variable conditionally defines the C<I_SYSUTSNAME> symbol,
+and indicates whether a C program should include <sys/utsname.h>.
+
+=item C<i_sysvfs>
+
+From F<i_sysvfs.U>:
+
+This variable conditionally defines the C<I_SYSVFS> symbol,
+and indicates whether a C program should include <sys/vfs.h>.
+
+=item C<i_syswait>
+
+From F<i_syswait.U>:
+
+This variable conditionally defines C<I_SYS_WAIT>, which indicates
+to the C program that it should include <sys/wait.h>.
+
+=item C<i_termio>
+
+From F<i_termio.U>:
+
+This variable conditionally defines the C<I_TERMIO> symbol, which
+indicates to the C program that it should include <termio.h> rather
+than <sgtty.h>.
+
+=item C<i_termios>
+
+From F<i_termio.U>:
+
+This variable conditionally defines the C<I_TERMIOS> symbol, which
+indicates to the C program that the C<POSIX> <termios.h> file is
+to be included.
+
+=item C<i_time>
+
+From F<i_time.U>:
+
+This variable conditionally defines C<I_TIME>, which indicates
+to the C program that it should include <time.h>.
+
+=item C<i_unistd>
+
+From F<i_unistd.U>:
+
+This variable conditionally defines the C<I_UNISTD> symbol, and indicates
+whether a C program should include <unistd.h>.
+
+=item C<i_ustat>
+
+From F<i_ustat.U>:
+
+This variable conditionally defines the C<I_USTAT> symbol, and indicates
+whether a C program should include <ustat.h>.
+
+=item C<i_utime>
+
+From F<i_utime.U>:
+
+This variable conditionally defines the C<I_UTIME> symbol, and indicates
+whether a C program should include <utime.h>.
+
+=item C<i_values>
+
+From F<i_values.U>:
+
+This variable conditionally defines the C<I_VALUES> symbol, and indicates
+whether a C program may include <values.h> to get symbols like C<MAXLONG>
+and friends.
+
+=item C<i_varargs>
+
+From F<i_varhdr.U>:
+
+This variable conditionally defines C<I_VARARGS>, which indicates
+to the C program that it should include <varargs.h>.
+
+=item C<i_varhdr>
+
+From F<i_varhdr.U>:
+
+Contains the name of the header to be included to get va_dcl definition.
+Typically one of F<varargs.h> or F<stdarg.h>.
+
+=item C<i_vfork>
+
+From F<i_vfork.U>:
+
+This variable conditionally defines the C<I_VFORK> symbol, and indicates
+whether a C program should include F<vfork.h>.
+
+=item C<ignore_versioned_solibs>
+
+From F<libs.U>:
+
+This variable should be non-empty if non-versioned shared
+libraries (F<libfoo.so.x.y>) are to be ignored (because they
+cannot be linked against).
+
+=item C<inc_version_list>
+
+From F<inc_version_list.U>:
+
+This variable specifies the list of subdirectories in over
+which F<perl.c>:incpush() and F<lib/lib.pm> will automatically
+search when adding directories to @C<INC>. The elements in
+the list are separated by spaces. This is only useful
+if you have a perl library directory tree structured like the
+default one. See C<INSTALL> for how this works. The versioned
+site_perl directory was introduced in 5.005, so that is the
+lowest possible value.
+
+This list includes architecture-dependent directories back to
+version $api_versionstring (e.g. 5.5.640) and
+architecture-independent directories all the way back to
+5.005.
+
+=item C<inc_version_list_init>
+
+From F<inc_version_list.U>:
+
+This variable holds the same list as inc_version_list, but
+each item is enclosed in double quotes and separated by commas,
+suitable for use in the C<PERL_INC_VERSION_LIST> initialization.
+
+=item C<incpath>
+
+From F<usrinc.U>:
+
+This variable must preceed the normal include path to get hte
+right one, as in F<$F<incpath/usr/include>> or F<$F<incpath/usr/lib>>.
+Value can be "" or F</bsd43> on mips.
+
+=item C<inews>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<initialinstalllocation>
+
+From F<bin.U>:
+
+When userelocatableinc is true, this variable holds the location
+that make install should copy the perl binary to, with all the
+run-time relocatable paths calculated from this at install time.
+When used, it is initialised to the original value of binexp, and
+then binexp is set to F<.../>, as the other binaries are found
+relative to the perl binary.
+
+=item C<installarchlib>
+
+From F<archlib.U>:
+
+This variable is really the same as archlibexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installbin>
+
+From F<bin.U>:
+
+This variable is the same as binexp unless C<AFS> is running in which case
+the user is explicitely prompted for it. This variable should always
+be used in your makefiles for maximum portability.
+
+=item C<installhtml1dir>
+
+From F<html1dir.U>:
+
+This variable is really the same as html1direxp, unless you are
+using a different installprefix. For extra portability, you
+should only use this variable within your makefiles.
+
+=item C<installhtml3dir>
+
+From F<html3dir.U>:
+
+This variable is really the same as html3direxp, unless you are
+using a different installprefix. For extra portability, you
+should only use this variable within your makefiles.
+
+=item C<installman1dir>
+
+From F<man1dir.U>:
+
+This variable is really the same as man1direxp, unless you are using
+C<AFS> in which case it points to the read/write location whereas
+man1direxp only points to the read-only access location. For extra
+portability, you should only use this variable within your makefiles.
+
+=item C<installman3dir>
+
+From F<man3dir.U>:
+
+This variable is really the same as man3direxp, unless you are using
+C<AFS> in which case it points to the read/write location whereas
+man3direxp only points to the read-only access location. For extra
+portability, you should only use this variable within your makefiles.
+
+=item C<installprefix>
+
+From F<installprefix.U>:
+
+This variable holds the name of the directory below which
+"make install" will install the package. For most users, this
+is the same as prefix. However, it is useful for
+installing the software into a different (usually temporary)
+location after which it can be bundled up and moved somehow
+to the final location specified by prefix.
+
+=item C<installprefixexp>
+
+From F<installprefix.U>:
+
+This variable holds the full absolute path of installprefix
+with all F<~>-expansion done.
+
+=item C<installprivlib>
+
+From F<privlib.U>:
+
+This variable is really the same as privlibexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installscript>
+
+From F<scriptdir.U>:
+
+This variable is usually the same as scriptdirexp, unless you are on
+a system running C<AFS>, in which case they may differ slightly. You
+should always use this variable within your makefiles for portability.
+
+=item C<installsitearch>
+
+From F<sitearch.U>:
+
+This variable is really the same as sitearchexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installsitebin>
+
+From F<sitebin.U>:
+
+This variable is usually the same as sitebinexp, unless you are on
+a system running C<AFS>, in which case they may differ slightly. You
+should always use this variable within your makefiles for portability.
+
+=item C<installsitehtml1dir>
+
+From F<sitehtml1dir.U>:
+
+This variable is really the same as sitehtml1direxp, unless you are using
+C<AFS> in which case it points to the read/write location whereas
+html1direxp only points to the read-only access location. For extra
+portability, you should only use this variable within your makefiles.
+
+=item C<installsitehtml3dir>
+
+From F<sitehtml3dir.U>:
+
+This variable is really the same as sitehtml3direxp, unless you are using
+C<AFS> in which case it points to the read/write location whereas
+html3direxp only points to the read-only access location. For extra
+portability, you should only use this variable within your makefiles.
+
+=item C<installsitelib>
+
+From F<sitelib.U>:
+
+This variable is really the same as sitelibexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installsiteman1dir>
+
+From F<siteman1dir.U>:
+
+This variable is really the same as siteman1direxp, unless you are using
+C<AFS> in which case it points to the read/write location whereas
+man1direxp only points to the read-only access location. For extra
+portability, you should only use this variable within your makefiles.
+
+=item C<installsiteman3dir>
+
+From F<siteman3dir.U>:
+
+This variable is really the same as siteman3direxp, unless you are using
+C<AFS> in which case it points to the read/write location whereas
+man3direxp only points to the read-only access location. For extra
+portability, you should only use this variable within your makefiles.
+
+=item C<installsitescript>
+
+From F<sitescript.U>:
+
+This variable is usually the same as sitescriptexp, unless you are on
+a system running C<AFS>, in which case they may differ slightly. You
+should always use this variable within your makefiles for portability.
+
+=item C<installstyle>
+
+From F<installstyle.U>:
+
+This variable describes the C<style> of the perl installation.
+This is intended to be useful for tools that need to
+manipulate entire perl distributions. Perl itself doesn't use
+this to find its libraries -- the library directories are
+stored directly in F<Config.pm>. Currently, there are only two
+styles: C<lib> and F<lib/perl5>. The default library locations
+(e.g. privlib, sitelib) are either F<$prefix/lib> or
+F<$prefix/lib/perl5>. The former is useful if $prefix is a
+directory dedicated to perl (e.g. F</opt/perl>), while the latter
+is useful if $prefix is shared by many packages, e.g. if
+$prefix=F</usr/local>.
+
+Unfortunately, while this C<style> variable is used to set
+defaults for all three directory hierarchies (core, vendor, and
+site), there is no guarantee that the same style is actually
+appropriate for all those directories. For example, $prefix
+might be F</opt/perl>, but $siteprefix might be F</usr/local>.
+(Perhaps, in retrospect, the C<lib> style should never have been
+supported, but it did seem like a nice idea at the time.)
+
+The situation is even less clear for tools such as MakeMaker
+that can be used to install additional modules into
+non-standard places. For example, if a user intends to install
+a module into a private directory (perhaps by setting C<PREFIX> on
+the F<Makefile.PL> command line), then there is no reason to
+assume that the Configure-time $installstyle setting will be
+relevant for that C<PREFIX>.
+
+This may later be extended to include other information, so
+be careful with pattern-matching on the results.
+
+For compatibility with F<perl5.005> and earlier, the default
+setting is based on whether or not $prefix contains the string
+C<perl>.
+
+=item C<installusrbinperl>
+
+From F<instubperl.U>:
+
+This variable tells whether Perl should be installed also as
+F</usr/bin/perl> in addition to
+F<$installbin/perl>
+
+=item C<installvendorarch>
+
+From F<vendorarch.U>:
+
+This variable is really the same as vendorarchexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorbin>
+
+From F<vendorbin.U>:
+
+This variable is really the same as vendorbinexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorhtml1dir>
+
+From F<vendorhtml1dir.U>:
+
+This variable is really the same as vendorhtml1direxp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorhtml3dir>
+
+From F<vendorhtml3dir.U>:
+
+This variable is really the same as vendorhtml3direxp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorlib>
+
+From F<vendorlib.U>:
+
+This variable is really the same as vendorlibexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorman1dir>
+
+From F<vendorman1dir.U>:
+
+This variable is really the same as vendorman1direxp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorman3dir>
+
+From F<vendorman3dir.U>:
+
+This variable is really the same as vendorman3direxp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<installvendorscript>
+
+From F<vendorscript.U>:
+
+This variable is really the same as vendorscriptexp but may differ on
+those systems using C<AFS>. For extra portability, only this variable
+should be used in makefiles.
+
+=item C<intsize>
+
+From F<intsize.U>:
+
+This variable contains the value of the C<INTSIZE> symbol, which
+indicates to the C program how many bytes there are in an int.
+
+=item C<issymlink>
+
+From F<issymlink.U>:
+
+This variable holds the test command to test for a symbolic link
+(if they are supported). Typical values include C<test -h> and
+C<test -L>.
+
+=item C<ivdformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<IV> as a signed decimal integer.
+
+=item C<ivsize>
+
+From F<perlxv.U>:
+
+This variable is the size of an C<IV> in bytes.
+
+=item C<ivtype>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's C<IV>.
+
+=back
+
+=cut
+
+=head2 k
+
+=over 4
+
+=cut
+
+=item C<known_extensions>
+
+From F<Extensions.U>:
+
+This variable holds a list of all C<XS> extensions included in
+the package.
+
+=item C<ksh>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=back
+
+=cut
+
+=head2 l
+
+=over 4
+
+=cut
+
+=item C<ld>
+
+From F<dlsrc.U>:
+
+This variable indicates the program to be used to link
+libraries for dynamic loading. On some systems, it is C<ld>.
+On C<ELF> systems, it should be $cc. Mostly, we'll try to respect
+the hint file setting.
+
+=item C<lddlflags>
+
+From F<dlsrc.U>:
+
+This variable contains any special flags that might need to be
+passed to $ld to create a shared library suitable for dynamic
+loading. It is up to the makefile to use it. For hpux, it
+should be C<-b>. For sunos 4.1, it is empty.
+
+=item C<ldflags>
+
+From F<ccflags.U>:
+
+This variable contains any additional C loader flags desired by
+the user. It is up to the Makefile to use this.
+
+=item C<ldflags_uselargefiles>
+
+From F<uselfs.U>:
+
+This variable contains the loader flags needed by large file builds
+and added to ldflags by hints files.
+
+=item C<ldlibpthname>
+
+From F<libperl.U>:
+
+This variable holds the name of the shared library
+search path, often C<LD_LIBRARY_PATH>. To get an empty
+string, the hints file must set this to C<none>.
+
+=item C<less>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the less program. After Configure runs,
+the value is reset to a plain C<less> and is not useful.
+
+=item C<lib_ext>
+
+From F<Unix.U>:
+
+This is an old synonym for _a.
+
+=item C<libc>
+
+From F<libc.U>:
+
+This variable contains the location of the C library.
+
+=item C<libperl>
+
+From F<libperl.U>:
+
+The perl executable is obtained by linking F<perlmain.c> with
+libperl, any static extensions (usually just DynaLoader),
+and any other libraries needed on this system. libperl
+is usually F<libperl.a>, but can also be F<libperl.so.xxx> if
+the user wishes to build a perl executable with a shared
+library.
+
+=item C<libpth>
+
+From F<libpth.U>:
+
+This variable holds the general path (space-separated) used to find
+libraries. It is intended to be used by other units.
+
+=item C<libs>
+
+From F<libs.U>:
+
+This variable holds the additional libraries we want to use.
+It is up to the Makefile to deal with it. The list can be empty.
+
+=item C<libsdirs>
+
+From F<libs.U>:
+
+This variable holds the directory names aka dirnames of the libraries
+we found and accepted, duplicates are removed.
+
+=item C<libsfiles>
+
+From F<libs.U>:
+
+This variable holds the filenames aka basenames of the libraries
+we found and accepted.
+
+=item C<libsfound>
+
+From F<libs.U>:
+
+This variable holds the full pathnames of the libraries
+we found and accepted.
+
+=item C<libspath>
+
+From F<libs.U>:
+
+This variable holds the directory names probed for libraries.
+
+=item C<libswanted>
+
+From F<Myinit.U>:
+
+This variable holds a list of all the libraries we want to
+search. The order is chosen to pick up the c library
+ahead of ucb or bsd libraries for SVR4.
+
+=item C<libswanted_uselargefiles>
+
+From F<uselfs.U>:
+
+This variable contains the libraries needed by large file builds
+and added to ldflags by hints files. It is a space separated list
+of the library names without the C<lib> prefix or any suffix, just
+like F<libswanted.>.
+
+=item C<line>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<lint>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<lkflags>
+
+From F<ccflags.U>:
+
+This variable contains any additional C partial linker flags desired by
+the user. It is up to the Makefile to use this.
+
+=item C<ln>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the ln program. After Configure runs,
+the value is reset to a plain C<ln> and is not useful.
+
+=item C<lns>
+
+From F<lns.U>:
+
+This variable holds the name of the command to make
+symbolic links (if they are supported). It can be used
+in the Makefile. It is either C<ln -s> or C<ln>
+
+=item C<localtime_r_proto>
+
+From F<d_localtime_r.U>:
+
+This variable encodes the prototype of localtime_r.
+It is zero if d_localtime_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_localtime_r
+is defined.
+
+=item C<locincpth>
+
+From F<ccflags.U>:
+
+This variable contains a list of additional directories to be
+searched by the compiler. The appropriate C<-I> directives will
+be added to ccflags. This is intended to simplify setting
+local directories from the Configure command line.
+It's not much, but it parallels the loclibpth stuff in F<libpth.U>.
+
+=item C<loclibpth>
+
+From F<libpth.U>:
+
+This variable holds the paths (space-separated) used to find local
+libraries. It is prepended to libpth, and is intended to be easily
+set from the command line.
+
+=item C<longdblsize>
+
+From F<d_longdbl.U>:
+
+This variable contains the value of the C<LONG_DOUBLESIZE> symbol, which
+indicates to the C program how many bytes there are in a long double,
+if this system supports long doubles.
+
+=item C<longlongsize>
+
+From F<d_longlong.U>:
+
+This variable contains the value of the C<LONGLONGSIZE> symbol, which
+indicates to the C program how many bytes there are in a long long,
+if this system supports long long.
+
+=item C<longsize>
+
+From F<intsize.U>:
+
+This variable contains the value of the C<LONGSIZE> symbol, which
+indicates to the C program how many bytes there are in a long.
+
+=item C<lp>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<lpr>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<ls>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the ls program. After Configure runs,
+the value is reset to a plain C<ls> and is not useful.
+
+=item C<lseeksize>
+
+From F<lseektype.U>:
+
+This variable defines lseektype to be something like off_t, long,
+or whatever type is used to declare lseek offset's type in the
+kernel (which also appears to be lseek's return type).
+
+=item C<lseektype>
+
+From F<lseektype.U>:
+
+This variable defines lseektype to be something like off_t, long,
+or whatever type is used to declare lseek offset's type in the
+kernel (which also appears to be lseek's return type).
+
+=back
+
+=cut
+
+=head2 m
+
+=over 4
+
+=cut
+
+=item C<mad>
+
+From F<mad.U>:
+
+This variable indicates that the Misc Attribute Definition code is to
+be compiled.
+
+=item C<madlyh>
+
+From F<mad.U>:
+
+If the Misc Attribute Decoration is to be compiled, this variable is
+set to the name of the extra header files to be used, else it is ''
+
+=item C<madlyobj>
+
+From F<mad.U>:
+
+If the Misc Attribute Decoration is to be compiled, this variable is
+set to the name of the extra object files to be used, else it is ''
+
+=item C<madlysrc>
+
+From F<mad.U>:
+
+If the Misc Attribute Decoration is to be compiled, this variable is
+set to the name of the extra C source files to be used, else it is ''
+
+=item C<mail>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<mailx>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<make>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the make program. After Configure runs,
+the value is reset to a plain C<make> and is not useful.
+
+=item C<make_set_make>
+
+From F<make.U>:
+
+Some versions of C<make> set the variable C<MAKE>. Others do not.
+This variable contains the string to be included in F<Makefile.SH>
+so that C<MAKE> is set if needed, and not if not needed.
+Possible values are:
+
+make_set_make=C<#> # If your make program handles this for you,
+
+make_set_make=C<MAKE=$make> # if it doesn't.
+
+This uses a comment character so that we can distinguish a
+C<set> value (from a previous F<config.sh> or Configure C<-D> option)
+from an uncomputed value.
+
+=item C<mallocobj>
+
+From F<mallocsrc.U>:
+
+This variable contains the name of the F<malloc.o> that this package
+generates, if that F<malloc.o> is preferred over the system malloc.
+Otherwise the value is null. This variable is intended for generating
+Makefiles. See mallocsrc.
+
+=item C<mallocsrc>
+
+From F<mallocsrc.U>:
+
+This variable contains the name of the F<malloc.c> that comes with
+the package, if that F<malloc.c> is preferred over the system malloc.
+Otherwise the value is null. This variable is intended for generating
+Makefiles.
+
+=item C<malloctype>
+
+From F<mallocsrc.U>:
+
+This variable contains the kind of ptr returned by malloc and realloc.
+
+=item C<man1dir>
+
+From F<man1dir.U>:
+
+This variable contains the name of the directory in which manual
+source pages are to be put. It is the responsibility of the
+F<Makefile.SH> to get the value of this into the proper command.
+You must be prepared to do the F<~name> expansion yourself.
+
+=item C<man1direxp>
+
+From F<man1dir.U>:
+
+This variable is the same as the man1dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<man1ext>
+
+From F<man1dir.U>:
+
+This variable contains the extension that the manual page should
+have: one of C<n>, C<l>, or C<1>. The Makefile must supply the F<.>.
+See man1dir.
+
+=item C<man3dir>
+
+From F<man3dir.U>:
+
+This variable contains the name of the directory in which manual
+source pages are to be put. It is the responsibility of the
+F<Makefile.SH> to get the value of this into the proper command.
+You must be prepared to do the F<~name> expansion yourself.
+
+=item C<man3direxp>
+
+From F<man3dir.U>:
+
+This variable is the same as the man3dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<man3ext>
+
+From F<man3dir.U>:
+
+This variable contains the extension that the manual page should
+have: one of C<n>, C<l>, or C<3>. The Makefile must supply the F<.>.
+See man3dir.
+
+=item C<mips_type>
+
+From F<usrinc.U>:
+
+This variable holds the environment type for the mips system.
+Possible values are "BSD 4.3" and "System V".
+
+=item C<mistrustnm>
+
+From F<Csym.U>:
+
+This variable can be used to establish a fallthrough for the cases
+where nm fails to find a symbol. If usenm is false or usenm is true
+and mistrustnm is false, this variable has no effect. If usenm is true
+and mistrustnm is C<compile>, a test program will be compiled to try to
+find any symbol that can't be located via nm lookup. If mistrustnm is
+C<run>, the test program will be run as well as being compiled.
+
+=item C<mkdir>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the mkdir program. After Configure runs,
+the value is reset to a plain C<mkdir> and is not useful.
+
+=item C<mmaptype>
+
+From F<d_mmap.U>:
+
+This symbol contains the type of pointer returned by mmap()
+(and simultaneously the type of the first argument).
+It can be C<void *> or C<caddr_t>.
+
+=item C<modetype>
+
+From F<modetype.U>:
+
+This variable defines modetype to be something like mode_t,
+int, unsigned short, or whatever type is used to declare file
+modes for system calls.
+
+=item C<more>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the more program. After Configure runs,
+the value is reset to a plain C<more> and is not useful.
+
+=item C<multiarch>
+
+From F<multiarch.U>:
+
+This variable conditionally defines the C<MULTIARCH> symbol
+which signifies the presence of multiplatform files.
+This is normally set by hints files.
+
+=item C<mv>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<myarchname>
+
+From F<archname.U>:
+
+This variable holds the architecture name computed by Configure in
+a previous run. It is not intended to be perused by any user and
+should never be set in a hint file.
+
+=item C<mydomain>
+
+From F<myhostname.U>:
+
+This variable contains the eventual value of the C<MYDOMAIN> symbol,
+which is the domain of the host the program is going to run on.
+The domain must be appended to myhostname to form a complete host name.
+The dot comes with mydomain, and need not be supplied by the program.
+
+=item C<myhostname>
+
+From F<myhostname.U>:
+
+This variable contains the eventual value of the C<MYHOSTNAME> symbol,
+which is the name of the host the program is going to run on.
+The domain is not kept with hostname, but must be gotten from mydomain.
+The dot comes with mydomain, and need not be supplied by the program.
+
+=item C<myuname>
+
+From F<Oldconfig.U>:
+
+The output of C<uname -a> if available, otherwise the hostname. On Xenix,
+pseudo variables assignments in the output are stripped, thank you. The
+whole thing is then lower-cased.
+
+=back
+
+=cut
+
+=head2 n
+
+=over 4
+
+=cut
+
+=item C<n>
+
+From F<n.U>:
+
+This variable contains the C<-n> flag if that is what causes the echo
+command to suppress newline. Otherwise it is null. Correct usage is
+$echo $n "prompt for a question: $c".
+
+=item C<need_va_copy>
+
+From F<need_va_copy.U>:
+
+This symbol, if defined, indicates that the system stores
+the variable argument list datatype, va_list, in a format
+that cannot be copied by simple assignment, so that some
+other means must be used when copying is required.
+As such systems vary in their provision (or non-provision)
+of copying mechanisms, F<handy.h> defines a platform-
+C<independent> macro, Perl_va_copy(src, dst), to do the job.
+
+=item C<netdb_hlen_type>
+
+From F<netdbtype.U>:
+
+This variable holds the type used for the 2nd argument to
+gethostbyaddr(). Usually, this is int or size_t or unsigned.
+This is only useful if you have gethostbyaddr(), naturally.
+
+=item C<netdb_host_type>
+
+From F<netdbtype.U>:
+
+This variable holds the type used for the 1st argument to
+gethostbyaddr(). Usually, this is char * or void *, possibly
+with or without a const prefix.
+This is only useful if you have gethostbyaddr(), naturally.
+
+=item C<netdb_name_type>
+
+From F<netdbtype.U>:
+
+This variable holds the type used for the argument to
+gethostbyname(). Usually, this is char * or const char *.
+This is only useful if you have gethostbyname(), naturally.
+
+=item C<netdb_net_type>
+
+From F<netdbtype.U>:
+
+This variable holds the type used for the 1st argument to
+getnetbyaddr(). Usually, this is int or long.
+This is only useful if you have getnetbyaddr(), naturally.
+
+=item C<nm>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the nm program. After Configure runs,
+the value is reset to a plain C<nm> and is not useful.
+
+=item C<nm_opt>
+
+From F<usenm.U>:
+
+This variable holds the options that may be necessary for nm.
+
+=item C<nm_so_opt>
+
+From F<usenm.U>:
+
+This variable holds the options that may be necessary for nm
+to work on a shared library but that can not be used on an
+archive library. Currently, this is only used by Linux, where
+nm --dynamic is *required* to get symbols from an C<ELF> library which
+has been stripped, but nm --dynamic is *fatal* on an archive library.
+Maybe Linux should just always set usenm=false.
+
+=item C<nonxs_ext>
+
+From F<Extensions.U>:
+
+This variable holds a list of all non-xs extensions included
+in the package. All of them will be built.
+
+=item C<nroff>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the nroff program. After Configure runs,
+the value is reset to a plain C<nroff> and is not useful.
+
+=item C<nv_overflows_integers_at>
+
+From F<perlxv.U>:
+
+This variable gives the largest integer value that NVs can hold
+as a constant floating point expression.
+If it could not be determined, it holds the value 0.
+
+=item C<nv_preserves_uv_bits>
+
+From F<perlxv.U>:
+
+This variable indicates how many of bits type uvtype
+a variable nvtype can preserve.
+
+=item C<nveformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<NV> using %e-ish floating point format.
+
+=item C<nvEUformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<NV> using %E-ish floating point format.
+
+=item C<nvfformat>
+
+From F<perlxvf.U>:
+
+This variable confains the format string used for printing
+a Perl C<NV> using %f-ish floating point format.
+
+=item C<nvFUformat>
+
+From F<perlxvf.U>:
+
+This variable confains the format string used for printing
+a Perl C<NV> using %F-ish floating point format.
+
+=item C<nvgformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<NV> using %g-ish floating point format.
+
+=item C<nvGUformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<NV> using %G-ish floating point format.
+
+=item C<nvsize>
+
+From F<perlxv.U>:
+
+This variable is the size of an C<NV> in bytes.
+
+=item C<nvtype>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's C<NV>.
+
+=back
+
+=cut
+
+=head2 o
+
+=over 4
+
+=cut
+
+=item C<o_nonblock>
+
+From F<nblock_io.U>:
+
+This variable bears the symbol value to be used during open() or fcntl()
+to turn on non-blocking I/O for a file descriptor. If you wish to switch
+between blocking and non-blocking, you may try ioctl(C<FIOSNBIO>) instead,
+but that is only supported by some devices.
+
+=item C<obj_ext>
+
+From F<Unix.U>:
+
+This is an old synonym for _o.
+
+=item C<old_pthread_create_joinable>
+
+From F<d_pthrattrj.U>:
+
+This variable defines the constant to use for creating joinable
+(aka undetached) pthreads. Unused if F<pthread.h> defines
+C<PTHREAD_CREATE_JOINABLE>. If used, possible values are
+C<PTHREAD_CREATE_UNDETACHED> and C<__UNDETACHED>.
+
+=item C<optimize>
+
+From F<ccflags.U>:
+
+This variable contains any F<optimizer/debugger> flag that should be used.
+It is up to the Makefile to use it.
+
+=item C<orderlib>
+
+From F<orderlib.U>:
+
+This variable is C<true> if the components of libraries must be ordered
+(with `lorder $* | tsort`) before placing them in an archive. Set to
+C<false> if ranlib or ar can generate random libraries.
+
+=item C<osname>
+
+From F<Oldconfig.U>:
+
+This variable contains the operating system name (e.g. sunos,
+solaris, hpux, etc.). It can be useful later on for setting
+defaults. Any spaces are replaced with underscores. It is set
+to a null string if we can't figure it out.
+
+=item C<osvers>
+
+From F<Oldconfig.U>:
+
+This variable contains the operating system version (e.g.
+4.1.3, 5.2, etc.). It is primarily used for helping select
+an appropriate hints file, but might be useful elsewhere for
+setting defaults. It is set to '' if we can't figure it out.
+We try to be flexible about how much of the version number
+to keep, e.g. if 4.1.1, 4.1.2, and 4.1.3 are essentially the
+same for this package, hints files might just be F<os_4.0> or
+F<os_4.1>, etc., not keeping separate files for each little release.
+
+=item C<otherlibdirs>
+
+From F<otherlibdirs.U>:
+
+This variable contains a colon-separated set of paths for the perl
+binary to search for additional library files or modules.
+These directories will be tacked to the end of @C<INC>.
+Perl will automatically search below each path for version-
+and architecture-specific directories. See inc_version_list
+for more details.
+A value of C< > means C<none> and is used to preserve this value
+for the next run through Configure.
+
+=back
+
+=cut
+
+=head2 p
+
+=over 4
+
+=cut
+
+=item C<package>
+
+From F<package.U>:
+
+This variable contains the name of the package being constructed.
+It is primarily intended for the use of later Configure units.
+
+=item C<pager>
+
+From F<pager.U>:
+
+This variable contains the name of the preferred pager on the system.
+Usual values are (the full pathnames of) more, less, pg, or cat.
+
+=item C<passcat>
+
+From F<nis.U>:
+
+This variable contains a command that produces the text of the
+F</etc/passwd> file. This is normally "cat F</etc/passwd>", but can be
+"ypcat passwd" when C<NIS> is used.
+On some systems, such as os390, there may be no equivalent
+command, in which case this variable is unset.
+
+=item C<patchlevel>
+
+From F<patchlevel.U>:
+
+The patchlevel level of this package.
+The value of patchlevel comes from the F<patchlevel.h> file.
+In a version number such as 5.6.1, this is the C<6>.
+In F<patchlevel.h>, this is referred to as C<PERL_VERSION>.
+
+=item C<path_sep>
+
+From F<Unix.U>:
+
+This is an old synonym for p_ in F<Head.U>, the character
+used to separate elements in the command shell search C<PATH>.
+
+=item C<perl>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<perl5>
+
+From F<perl5.U>:
+
+This variable contains the full path (if any) to a previously
+installed F<perl5.005> or later suitable for running the script
+to determine inc_version_list.
+
+=back
+
+=cut
+
+=head2 P
+
+=over 4
+
+=cut
+
+=item C<PERL_API_REVISION>
+
+From F<patchlevel.h>:
+
+This number describes the earliest compatible C<PERL_REVISION> of
+Perl (C<compatibility> here being defined as sufficient F<binary/C<API>>
+compatibility to run C<XS> code built with the older version).
+Normally this does not change across maintenance releases.
+Please read the comment in F<patchlevel.h>.
+
+=item C<PERL_API_SUBVERSION>
+
+From F<patchlevel.h>:
+
+This number describes the earliest compatible C<PERL_SUBVERSION> of
+Perl (C<compatibility> here being defined as sufficient F<binary/C<API>>
+compatibility to run C<XS> code built with the older version).
+Normally this does not change across maintenance releases.
+Please read the comment in F<patchlevel.h>.
+
+=item C<PERL_API_VERSION>
+
+From F<patchlevel.h>:
+
+This number describes the earliest compatible C<PERL_VERSION> of
+Perl (C<compatibility> here being defined as sufficient F<binary/C<API>>
+compatibility to run C<XS> code built with the older version).
+Normally this does not change across maintenance releases.
+Please read the comment in F<patchlevel.h>.
+
+=item C<PERL_CONFIG_SH>
+
+From F<Oldsyms.U>:
+
+This is set to C<true> in F<config.sh> so that a shell script
+sourcing F<config.sh> can tell if it has been sourced already.
+
+=item C<PERL_PATCHLEVEL>
+
+From F<Oldsyms.U>:
+
+This symbol reflects the patchlevel, if available. Will usually
+come from the F<.patch> file, which is available when the perl
+source tree was fetched with rsync.
+
+=item C<perl_patchlevel>
+
+From F<patchlevel.U>:
+
+This is the Perl patch level, a numeric change identifier,
+as defined by whichever source code maintenance system
+is used to maintain the patches; currently Perforce.
+It does not correlate with the Perl version numbers or
+the maintenance versus development dichotomy except
+by also being increasing.
+
+=item C<PERL_REVISION>
+
+From F<Oldsyms.U>:
+
+In a Perl version number such as 5.6.2, this is the 5.
+This value is manually set in F<patchlevel.h>
+
+=item C<PERL_SUBVERSION>
+
+From F<Oldsyms.U>:
+
+In a Perl version number such as 5.6.2, this is the 2.
+Values greater than 50 represent potentially unstable
+development subversions.
+This value is manually set in F<patchlevel.h>
+
+=item C<PERL_VERSION>
+
+From F<Oldsyms.U>:
+
+In a Perl version number such as 5.6.2, this is the 6.
+This value is manually set in F<patchlevel.h>
+
+=item C<perladmin>
+
+From F<perladmin.U>:
+
+Electronic mail address of the perl5 administrator.
+
+=item C<perllibs>
+
+From F<End.U>:
+
+The list of libraries needed by Perl only (any libraries needed
+by extensions only will by dropped, if using dynamic loading).
+
+=item C<perlpath>
+
+From F<perlpath.U>:
+
+This variable contains the eventual value of the C<PERLPATH> symbol,
+which contains the name of the perl interpreter to be used in
+shell scripts and in the "eval C<exec>" idiom. This variable is
+not necessarily the pathname of the file containing the perl
+interpreter; you must append the executable extension (_exe) if
+it is not already present. Note that Perl code that runs during
+the Perl build process cannot reference this variable, as Perl
+may not have been installed, or even if installed, may be a
+different version of Perl.
+
+=item C<pg>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the pg program. After Configure runs,
+the value is reset to a plain C<pg> and is not useful.
+
+=item C<phostname>
+
+From F<myhostname.U>:
+
+This variable contains the eventual value of the C<PHOSTNAME> symbol,
+which is a command that can be fed to popen() to get the host name.
+The program should probably not presume that the domain is or isn't
+there already.
+
+=item C<pidtype>
+
+From F<pidtype.U>:
+
+This variable defines C<PIDTYPE> to be something like pid_t, int,
+ushort, or whatever type is used to declare process ids in the kernel.
+
+=item C<plibpth>
+
+From F<libpth.U>:
+
+Holds the private path used by Configure to find out the libraries.
+Its value is prepend to libpth. This variable takes care of special
+machines, like the mips. Usually, it should be empty.
+
+=item C<pmake>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<pr>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<prefix>
+
+From F<prefix.U>:
+
+This variable holds the name of the directory below which the
+user will install the package. Usually, this is F</usr/local>, and
+executables go in F</usr/local/bin>, library stuff in F</usr/local/lib>,
+man pages in F</usr/local/man>, etc. It is only used to set defaults
+for things in F<bin.U>, F<mansrc.U>, F<privlib.U>, or F<scriptdir.U>.
+
+=item C<prefixexp>
+
+From F<prefix.U>:
+
+This variable holds the full absolute path of the directory below
+which the user will install the package. Derived from prefix.
+
+=item C<privlib>
+
+From F<privlib.U>:
+
+This variable contains the eventual value of the C<PRIVLIB> symbol,
+which is the name of the private library for this package. It may
+have a F<~> on the front. It is up to the makefile to eventually create
+this directory while performing installation (with F<~> substitution).
+
+=item C<privlibexp>
+
+From F<privlib.U>:
+
+This variable is the F<~name> expanded version of privlib, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<procselfexe>
+
+From F<d_procselfexe.U>:
+
+If d_procselfexe is defined, $procselfexe is the filename
+of the symbolic link pointing to the absolute pathname of
+the executing program.
+
+=item C<prototype>
+
+From F<prototype.U>:
+
+This variable holds the eventual value of C<CAN_PROTOTYPE>, which
+indicates the C compiler can handle funciton prototypes.
+
+=item C<ptrsize>
+
+From F<ptrsize.U>:
+
+This variable contains the value of the C<PTRSIZE> symbol, which
+indicates to the C program how many bytes there are in a pointer.
+
+=back
+
+=cut
+
+=head2 q
+
+=over 4
+
+=cut
+
+=item C<quadkind>
+
+From F<quadtype.U>:
+
+This variable, if defined, encodes the type of a quad:
+1 = int, 2 = long, 3 = long long, 4 = int64_t.
+
+=item C<quadtype>
+
+From F<quadtype.U>:
+
+This variable defines Quad_t to be something like long, int,
+long long, int64_t, or whatever type is used for 64-bit integers.
+
+=back
+
+=cut
+
+=head2 r
+
+=over 4
+
+=cut
+
+=item C<randbits>
+
+From F<randfunc.U>:
+
+Indicates how many bits are produced by the function used to
+generate normalized random numbers.
+
+=item C<randfunc>
+
+From F<randfunc.U>:
+
+Indicates the name of the random number function to use.
+Values include drand48, random, and rand. In C programs,
+the C<Drand01> macro is defined to generate uniformly distributed
+random numbers over the range [0., 1.[ (see drand01 and nrand).
+
+=item C<random_r_proto>
+
+From F<d_random_r.U>:
+
+This variable encodes the prototype of random_r.
+It is zero if d_random_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_random_r
+is defined.
+
+=item C<randseedtype>
+
+From F<randfunc.U>:
+
+Indicates the type of the argument of the seedfunc.
+
+=item C<ranlib>
+
+From F<orderlib.U>:
+
+This variable is set to the pathname of the ranlib program, if it is
+needed to generate random libraries. Set to C<:> if ar can generate
+random libraries or if random libraries are not supported
+
+=item C<rd_nodata>
+
+From F<nblock_io.U>:
+
+This variable holds the return code from read() when no data is
+present. It should be -1, but some systems return 0 when C<O_NDELAY> is
+used, which is a shame because you cannot make the difference between
+no data and an F<EOF.>. Sigh!
+
+=item C<readdir64_r_proto>
+
+From F<d_readdir64_r.U>:
+
+This variable encodes the prototype of readdir64_r.
+It is zero if d_readdir64_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_readdir64_r
+is defined.
+
+=item C<readdir_r_proto>
+
+From F<d_readdir_r.U>:
+
+This variable encodes the prototype of readdir_r.
+It is zero if d_readdir_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_readdir_r
+is defined.
+
+=item C<revision>
+
+From F<patchlevel.U>:
+
+The value of revision comes from the F<patchlevel.h> file.
+In a version number such as 5.6.1, this is the C<5>.
+In F<patchlevel.h>, this is referred to as C<PERL_REVISION>.
+
+=item C<rm>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the rm program. After Configure runs,
+the value is reset to a plain C<rm> and is not useful.
+
+=item C<rm_try>
+
+From F<Unix.U>:
+
+This is a cleanup variable for try test programs.
+Internal Configure use only.
+
+=item C<rmail>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<run>
+
+From F<Cross.U>:
+
+This variable contains the command used by Configure
+to copy and execute a cross-compiled executable in the
+target host. Useful and available only during Perl build.
+Empty string '' if not cross-compiling.
+
+=item C<runnm>
+
+From F<usenm.U>:
+
+This variable contains C<true> or C<false> depending whether the
+nm extraction should be performed or not, according to the value
+of usenm and the flags on the Configure command line.
+
+=back
+
+=cut
+
+=head2 s
+
+=over 4
+
+=cut
+
+=item C<sched_yield>
+
+From F<d_pthread_y.U>:
+
+This variable defines the way to yield the execution
+of the current thread.
+
+=item C<scriptdir>
+
+From F<scriptdir.U>:
+
+This variable holds the name of the directory in which the user wants
+to put publicly scripts for the package in question. It is either
+the same directory as for binaries, or a special one that can be
+mounted across different architectures, like F</usr/share>. Programs
+must be prepared to deal with F<~name> expansion.
+
+=item C<scriptdirexp>
+
+From F<scriptdir.U>:
+
+This variable is the same as scriptdir, but is filename expanded
+at configuration time, for programs not wanting to bother with it.
+
+=item C<sed>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the sed program. After Configure runs,
+the value is reset to a plain C<sed> and is not useful.
+
+=item C<seedfunc>
+
+From F<randfunc.U>:
+
+Indicates the random number generating seed function.
+Values include srand48, srandom, and srand.
+
+=item C<selectminbits>
+
+From F<selectminbits.U>:
+
+This variable holds the minimum number of bits operated by select.
+That is, if you do select(n, ...), how many bits at least will be
+cleared in the masks if some activity is detected. Usually this
+is either n or 32*ceil(F<n/32>), especially many little-endians do
+the latter. This is only useful if you have select(), naturally.
+
+=item C<selecttype>
+
+From F<selecttype.U>:
+
+This variable holds the type used for the 2nd, 3rd, and 4th
+arguments to select. Usually, this is C<fd_set *>, if C<HAS_FD_SET>
+is defined, and C<int *> otherwise. This is only useful if you
+have select(), naturally.
+
+=item C<sendmail>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<setgrent_r_proto>
+
+From F<d_setgrent_r.U>:
+
+This variable encodes the prototype of setgrent_r.
+It is zero if d_setgrent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_setgrent_r
+is defined.
+
+=item C<sethostent_r_proto>
+
+From F<d_sethostent_r.U>:
+
+This variable encodes the prototype of sethostent_r.
+It is zero if d_sethostent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_sethostent_r
+is defined.
+
+=item C<setlocale_r_proto>
+
+From F<d_setlocale_r.U>:
+
+This variable encodes the prototype of setlocale_r.
+It is zero if d_setlocale_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_setlocale_r
+is defined.
+
+=item C<setnetent_r_proto>
+
+From F<d_setnetent_r.U>:
+
+This variable encodes the prototype of setnetent_r.
+It is zero if d_setnetent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_setnetent_r
+is defined.
+
+=item C<setprotoent_r_proto>
+
+From F<d_setprotoent_r.U>:
+
+This variable encodes the prototype of setprotoent_r.
+It is zero if d_setprotoent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_setprotoent_r
+is defined.
+
+=item C<setpwent_r_proto>
+
+From F<d_setpwent_r.U>:
+
+This variable encodes the prototype of setpwent_r.
+It is zero if d_setpwent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_setpwent_r
+is defined.
+
+=item C<setservent_r_proto>
+
+From F<d_setservent_r.U>:
+
+This variable encodes the prototype of setservent_r.
+It is zero if d_setservent_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_setservent_r
+is defined.
+
+=item C<sGMTIME_max>
+
+From F<time_size.U>:
+
+This variable defines the maximum value of the time_t offset that
+the system function gmtime () accepts
+
+=item C<sGMTIME_min>
+
+From F<time_size.U>:
+
+This variable defines the minimum value of the time_t offset that
+the system function gmtime () accepts
+
+=item C<sh>
+
+From F<sh.U>:
+
+This variable contains the full pathname of the shell used
+on this system to execute Bourne shell scripts. Usually, this will be
+F</bin/sh>, though it's possible that some systems will have F</bin/ksh>,
+F</bin/pdksh>, F</bin/ash>, F</bin/bash>, or even something such as
+D:F</bin/sh.exe>.
+This unit comes before F<Options.U>, so you can't set sh with a C<-D>
+option, though you can override this (and startsh)
+with C<-O -Dsh=F</bin/whatever> -Dstartsh=whatever>
+
+=item C<shar>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<sharpbang>
+
+From F<spitshell.U>:
+
+This variable contains the string #! if this system supports that
+construct.
+
+=item C<shmattype>
+
+From F<d_shmat.U>:
+
+This symbol contains the type of pointer returned by shmat().
+It can be C<void *> or C<char *>.
+
+=item C<shortsize>
+
+From F<intsize.U>:
+
+This variable contains the value of the C<SHORTSIZE> symbol which
+indicates to the C program how many bytes there are in a short.
+
+=item C<shrpenv>
+
+From F<libperl.U>:
+
+If the user builds a shared F<libperl.so>, then we need to tell the
+C<perl> executable where it will be able to find the installed F<libperl.so>.
+One way to do this on some systems is to set the environment variable
+C<LD_RUN_PATH> to the directory that will be the final location of the
+shared F<libperl.so>. The makefile can use this with something like
+$shrpenv $(C<CC>) -o perl F<perlmain.o> $libperl $libs
+Typical values are
+shrpenv="env C<LD_RUN_PATH>=F<$archlibexp/C<CORE>>"
+or
+shrpenv=''
+See the main perl F<Makefile.SH> for actual working usage.
+Alternatively, we might be able to use a command line option such
+as -R F<$archlibexp/C<CORE>> (Solaris) or -Wl,-rpath
+F<$archlibexp/C<CORE>> (Linux).
+
+=item C<shsharp>
+
+From F<spitshell.U>:
+
+This variable tells further Configure units whether your sh can
+handle # comments.
+
+=item C<sig_count>
+
+From F<sig_name.U>:
+
+This variable holds a number larger than the largest valid
+signal number. This is usually the same as the C<NSIG> macro.
+
+=item C<sig_name>
+
+From F<sig_name.U>:
+
+This variable holds the signal names, space separated. The leading
+C<SIG> in signal name is removed. A C<ZERO> is prepended to the list.
+This is currently not used, sig_name_init is used instead.
+
+=item C<sig_name_init>
+
+From F<sig_name.U>:
+
+This variable holds the signal names, enclosed in double quotes and
+separated by commas, suitable for use in the C<SIG_NAME> definition
+below. A C<ZERO> is prepended to the list, and the list is
+terminated with a plain 0. The leading C<SIG> in signal names
+is removed. See sig_num.
+
+=item C<sig_num>
+
+From F<sig_name.U>:
+
+This variable holds the signal numbers, space separated. A C<ZERO> is
+prepended to the list (corresponding to the fake C<SIGZERO>).
+Those numbers correspond to the value of the signal listed
+in the same place within the sig_name list.
+This is currently not used, sig_num_init is used instead.
+
+=item C<sig_num_init>
+
+From F<sig_name.U>:
+
+This variable holds the signal numbers, enclosed in double quotes and
+separated by commas, suitable for use in the C<SIG_NUM> definition
+below. A C<ZERO> is prepended to the list, and the list is
+terminated with a plain 0.
+
+=item C<sig_size>
+
+From F<sig_name.U>:
+
+This variable contains the number of elements of the sig_name
+and sig_num arrays.
+
+=item C<signal_t>
+
+From F<d_voidsig.U>:
+
+This variable holds the type of the signal handler (void or int).
+
+=item C<sitearch>
+
+From F<sitearch.U>:
+
+This variable contains the eventual value of the C<SITEARCH> symbol,
+which is the name of the private library for this package. It may
+have a F<~> on the front. It is up to the makefile to eventually create
+this directory while performing installation (with F<~> substitution).
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+architecture-dependent modules in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<sitearchexp>
+
+From F<sitearch.U>:
+
+This variable is the F<~name> expanded version of sitearch, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<sitebin>
+
+From F<sitebin.U>:
+
+This variable holds the name of the directory in which the user wants
+to put add-on publicly executable files for the package in question. It
+is most often a local directory such as F</usr/local/bin>. Programs using
+this variable must be prepared to deal with F<~name> substitution.
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+executables in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<sitebinexp>
+
+From F<sitebin.U>:
+
+This is the same as the sitebin variable, but is filename expanded at
+configuration time, for use in your makefiles.
+
+=item C<sitehtml1dir>
+
+From F<sitehtml1dir.U>:
+
+This variable contains the name of the directory in which site-specific
+html source pages are to be put. It is the responsibility of the
+F<Makefile.SH> to get the value of this into the proper command.
+You must be prepared to do the F<~name> expansion yourself.
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+html pages in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<sitehtml1direxp>
+
+From F<sitehtml1dir.U>:
+
+This variable is the same as the sitehtml1dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<sitehtml3dir>
+
+From F<sitehtml3dir.U>:
+
+This variable contains the name of the directory in which site-specific
+library html source pages are to be put. It is the responsibility of the
+F<Makefile.SH> to get the value of this into the proper command.
+You must be prepared to do the F<~name> expansion yourself.
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+library html pages in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<sitehtml3direxp>
+
+From F<sitehtml3dir.U>:
+
+This variable is the same as the sitehtml3dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<sitelib>
+
+From F<sitelib.U>:
+
+This variable contains the eventual value of the C<SITELIB> symbol,
+which is the name of the private library for this package. It may
+have a F<~> on the front. It is up to the makefile to eventually create
+this directory while performing installation (with F<~> substitution).
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+architecture-independent modules in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<sitelib_stem>
+
+From F<sitelib.U>:
+
+This variable is $sitelibexp with any trailing version-specific component
+removed. The elements in inc_version_list (F<inc_version_list.U>) can
+be tacked onto this variable to generate a list of directories to search.
+
+=item C<sitelibexp>
+
+From F<sitelib.U>:
+
+This variable is the F<~name> expanded version of sitelib, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<siteman1dir>
+
+From F<siteman1dir.U>:
+
+This variable contains the name of the directory in which site-specific
+manual source pages are to be put. It is the responsibility of the
+F<Makefile.SH> to get the value of this into the proper command.
+You must be prepared to do the F<~name> expansion yourself.
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+man1 pages in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<siteman1direxp>
+
+From F<siteman1dir.U>:
+
+This variable is the same as the siteman1dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<siteman3dir>
+
+From F<siteman3dir.U>:
+
+This variable contains the name of the directory in which site-specific
+library man source pages are to be put. It is the responsibility of the
+F<Makefile.SH> to get the value of this into the proper command.
+You must be prepared to do the F<~name> expansion yourself.
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+man3 pages in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<siteman3direxp>
+
+From F<siteman3dir.U>:
+
+This variable is the same as the siteman3dir variable, but is filename
+expanded at configuration time, for convenient use in makefiles.
+
+=item C<siteprefix>
+
+From F<siteprefix.U>:
+
+This variable holds the full absolute path of the directory below
+which the user will install add-on packages.
+See C<INSTALL> for usage and examples.
+
+=item C<siteprefixexp>
+
+From F<siteprefix.U>:
+
+This variable holds the full absolute path of the directory below
+which the user will install add-on packages. Derived from siteprefix.
+
+=item C<sitescript>
+
+From F<sitescript.U>:
+
+This variable holds the name of the directory in which the user wants
+to put add-on publicly executable files for the package in question. It
+is most often a local directory such as F</usr/local/bin>. Programs using
+this variable must be prepared to deal with F<~name> substitution.
+The standard distribution will put nothing in this directory.
+After perl has been installed, users may install their own local
+scripts in this directory with
+MakeMaker F<Makefile.PL>
+or equivalent. See C<INSTALL> for details.
+
+=item C<sitescriptexp>
+
+From F<sitescript.U>:
+
+This is the same as the sitescript variable, but is filename expanded at
+configuration time, for use in your makefiles.
+
+=item C<sizesize>
+
+From F<sizesize.U>:
+
+This variable contains the size of a sizetype in bytes.
+
+=item C<sizetype>
+
+From F<sizetype.U>:
+
+This variable defines sizetype to be something like size_t,
+unsigned long, or whatever type is used to declare length
+parameters for string functions.
+
+=item C<sleep>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<sLOCALTIME_max>
+
+From F<time_size.U>:
+
+This variable defines the maximum value of the time_t offset that
+the system function localtime () accepts
+
+=item C<sLOCALTIME_min>
+
+From F<time_size.U>:
+
+This variable defines the minimum value of the time_t offset that
+the system function localtime () accepts
+
+=item C<smail>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<so>
+
+From F<so.U>:
+
+This variable holds the extension used to identify shared libraries
+(also known as shared objects) on the system. Usually set to C<so>.
+
+=item C<sockethdr>
+
+From F<d_socket.U>:
+
+This variable has any cpp C<-I> flags needed for socket support.
+
+=item C<socketlib>
+
+From F<d_socket.U>:
+
+This variable has the names of any libraries needed for socket support.
+
+=item C<socksizetype>
+
+From F<socksizetype.U>:
+
+This variable holds the type used for the size argument
+for various socket calls like accept. Usual values include
+socklen_t, size_t, and int.
+
+=item C<sort>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the sort program. After Configure runs,
+the value is reset to a plain C<sort> and is not useful.
+
+=item C<spackage>
+
+From F<package.U>:
+
+This variable contains the name of the package being constructed,
+with the first letter uppercased, F<i.e>. suitable for starting
+sentences.
+
+=item C<spitshell>
+
+From F<spitshell.U>:
+
+This variable contains the command necessary to spit out a runnable
+shell on this system. It is either cat or a grep C<-v> for # comments.
+
+=item C<sPRId64>
+
+From F<quadfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format 64-bit decimal numbers (format C<d>) for output.
+
+=item C<sPRIeldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<e>) for output.
+
+=item C<sPRIEUldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<E>) for output.
+The C<U> in the name is to separate this from sPRIeldbl so that even
+case-blind systems can see the difference.
+
+=item C<sPRIfldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<f>) for output.
+
+=item C<sPRIFUldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<F>) for output.
+The C<U> in the name is to separate this from sPRIfldbl so that even
+case-blind systems can see the difference.
+
+=item C<sPRIgldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<g>) for output.
+
+=item C<sPRIGUldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<G>) for output.
+The C<U> in the name is to separate this from sPRIgldbl so that even
+case-blind systems can see the difference.
+
+=item C<sPRIi64>
+
+From F<quadfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format 64-bit decimal numbers (format C<i>) for output.
+
+=item C<sPRIo64>
+
+From F<quadfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format 64-bit octal numbers (format C<o>) for output.
+
+=item C<sPRIu64>
+
+From F<quadfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format 64-bit unsigned decimal numbers (format C<u>) for output.
+
+=item C<sPRIx64>
+
+From F<quadfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format 64-bit hexadecimal numbers (format C<x>) for output.
+
+=item C<sPRIXU64>
+
+From F<quadfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format 64-bit hExADECimAl numbers (format C<X>) for output.
+The C<U> in the name is to separate this from sPRIx64 so that even
+case-blind systems can see the difference.
+
+=item C<srand48_r_proto>
+
+From F<d_srand48_r.U>:
+
+This variable encodes the prototype of srand48_r.
+It is zero if d_srand48_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_srand48_r
+is defined.
+
+=item C<srandom_r_proto>
+
+From F<d_srandom_r.U>:
+
+This variable encodes the prototype of srandom_r.
+It is zero if d_srandom_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_srandom_r
+is defined.
+
+=item C<src>
+
+From F<src.U>:
+
+This variable holds the (possibly relative) path of the package source.
+It is up to the Makefile to use this variable and set C<VPATH> accordingly
+to find the sources remotely. Use $pkgsrc to have an absolute path.
+
+=item C<sSCNfldbl>
+
+From F<longdblfio.U>:
+
+This variable, if defined, contains the string used by stdio to
+format long doubles (format C<f>) for input.
+
+=item C<ssizetype>
+
+From F<ssizetype.U>:
+
+This variable defines ssizetype to be something like ssize_t,
+long or int. It is used by functions that return a count
+of bytes or an error condition. It must be a signed type.
+We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+
+=item C<startperl>
+
+From F<startperl.U>:
+
+This variable contains the string to put on the front of a perl
+script to make sure (hopefully) that it runs with perl and not some
+shell. Of course, that leading line must be followed by the classical
+perl idiom:
+eval 'exec perl -S $0 ${1+C<$@>}'
+if $running_under_some_shell;
+to guarantee perl startup should the shell execute the script. Note
+that this magic incatation is not understood by csh.
+
+=item C<startsh>
+
+From F<startsh.U>:
+
+This variable contains the string to put on the front of a shell
+script to make sure (hopefully) that it runs with sh and not some
+other shell.
+
+=item C<static_ext>
+
+From F<Extensions.U>:
+
+This variable holds a list of C<XS> extension files we want to
+link statically into the package. It is used by Makefile.
+
+=item C<stdchar>
+
+From F<stdchar.U>:
+
+This variable conditionally defines C<STDCHAR> to be the type of char
+used in F<stdio.h>. It has the values "unsigned char" or C<char>.
+
+=item C<stdio_base>
+
+From F<d_stdstdio.U>:
+
+This variable defines how, given a C<FILE> pointer, fp, to access the
+_base field (or equivalent) of F<stdio.h>'s C<FILE> structure. This will
+be used to define the macro FILE_base(fp).
+
+=item C<stdio_bufsiz>
+
+From F<d_stdstdio.U>:
+
+This variable defines how, given a C<FILE> pointer, fp, to determine
+the number of bytes store in the I/O buffer pointer to by the
+_base field (or equivalent) of F<stdio.h>'s C<FILE> structure. This will
+be used to define the macro FILE_bufsiz(fp).
+
+=item C<stdio_cnt>
+
+From F<d_stdstdio.U>:
+
+This variable defines how, given a C<FILE> pointer, fp, to access the
+_cnt field (or equivalent) of F<stdio.h>'s C<FILE> structure. This will
+be used to define the macro FILE_cnt(fp).
+
+=item C<stdio_filbuf>
+
+From F<d_stdstdio.U>:
+
+This variable defines how, given a C<FILE> pointer, fp, to tell
+stdio to refill its internal buffers (?). This will
+be used to define the macro FILE_filbuf(fp).
+
+=item C<stdio_ptr>
+
+From F<d_stdstdio.U>:
+
+This variable defines how, given a C<FILE> pointer, fp, to access the
+_ptr field (or equivalent) of F<stdio.h>'s C<FILE> structure. This will
+be used to define the macro FILE_ptr(fp).
+
+=item C<stdio_stream_array>
+
+From F<stdio_streams.U>:
+
+This variable tells the name of the array holding the stdio streams.
+Usual values include _iob, __iob, and __sF.
+
+=item C<strerror_r_proto>
+
+From F<d_strerror_r.U>:
+
+This variable encodes the prototype of strerror_r.
+It is zero if d_strerror_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_strerror_r
+is defined.
+
+=item C<strings>
+
+From F<i_string.U>:
+
+This variable holds the full path of the string header that will be
+used. Typically F</usr/include/string.h> or F</usr/include/strings.h>.
+
+=item C<submit>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<subversion>
+
+From F<patchlevel.U>:
+
+The subversion level of this package.
+The value of subversion comes from the F<patchlevel.h> file.
+In a version number such as 5.6.1, this is the C<1>.
+In F<patchlevel.h>, this is referred to as C<PERL_SUBVERSION>.
+This is unique to perl.
+
+=item C<sysman>
+
+From F<sysman.U>:
+
+This variable holds the place where the manual is located on this
+system. It is not the place where the user wants to put his manual
+pages. Rather it is the place where Configure may look to find manual
+for unix commands (section 1 of the manual usually). See mansrc.
+
+=back
+
+=cut
+
+=head2 t
+
+=over 4
+
+=cut
+
+=item C<tail>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<tar>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<targetarch>
+
+From F<Cross.U>:
+
+If cross-compiling, this variable contains the target architecture.
+If not, this will be empty.
+
+=item C<tbl>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<tee>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<test>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the test program. After Configure runs,
+the value is reset to a plain C<test> and is not useful.
+
+=item C<timeincl>
+
+From F<i_time.U>:
+
+This variable holds the full path of the included time header(s).
+
+=item C<timetype>
+
+From F<d_time.U>:
+
+This variable holds the type returned by time(). It can be long,
+or time_t on C<BSD> sites (in which case <sys/types.h> should be
+included). Anyway, the type Time_t should be used.
+
+=item C<tmpnam_r_proto>
+
+From F<d_tmpnam_r.U>:
+
+This variable encodes the prototype of tmpnam_r.
+It is zero if d_tmpnam_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_tmpnam_r
+is defined.
+
+=item C<to>
+
+From F<Cross.U>:
+
+This variable contains the command used by Configure
+to copy to from the target host. Useful and available
+only during Perl build.
+The string C<:> if not cross-compiling.
+
+=item C<touch>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the touch program. After Configure runs,
+the value is reset to a plain C<touch> and is not useful.
+
+=item C<tr>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the tr program. After Configure runs,
+the value is reset to a plain C<tr> and is not useful.
+
+=item C<trnl>
+
+From F<trnl.U>:
+
+This variable contains the value to be passed to the tr(1)
+command to transliterate a newline. Typical values are
+C<\012> and C<\n>. This is needed for C<EBCDIC> systems where
+newline is not necessarily C<\012>.
+
+=item C<troff>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<ttyname_r_proto>
+
+From F<d_ttyname_r.U>:
+
+This variable encodes the prototype of ttyname_r.
+It is zero if d_ttyname_r is undef, and one of the
+C<REENTRANT_PROTO_T_ABC> macros of F<reentr.h> if d_ttyname_r
+is defined.
+
+=back
+
+=cut
+
+=head2 u
+
+=over 4
+
+=cut
+
+=item C<u16size>
+
+From F<perlxv.U>:
+
+This variable is the size of an U16 in bytes.
+
+=item C<u16type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's U16.
+
+=item C<u32size>
+
+From F<perlxv.U>:
+
+This variable is the size of an U32 in bytes.
+
+=item C<u32type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's U32.
+
+=item C<u64size>
+
+From F<perlxv.U>:
+
+This variable is the size of an U64 in bytes.
+
+=item C<u64type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's U64.
+
+=item C<u8size>
+
+From F<perlxv.U>:
+
+This variable is the size of an U8 in bytes.
+
+=item C<u8type>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's U8.
+
+=item C<uidformat>
+
+From F<uidf.U>:
+
+This variable contains the format string used for printing a Uid_t.
+
+=item C<uidsign>
+
+From F<uidsign.U>:
+
+This variable contains the signedness of a uidtype.
+1 for unsigned, -1 for signed.
+
+=item C<uidsize>
+
+From F<uidsize.U>:
+
+This variable contains the size of a uidtype in bytes.
+
+=item C<uidtype>
+
+From F<uidtype.U>:
+
+This variable defines Uid_t to be something like uid_t, int,
+ushort, or whatever type is used to declare user ids in the kernel.
+
+=item C<uname>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the uname program. After Configure runs,
+the value is reset to a plain C<uname> and is not useful.
+
+=item C<uniq>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the uniq program. After Configure runs,
+the value is reset to a plain C<uniq> and is not useful.
+
+=item C<uquadtype>
+
+From F<quadtype.U>:
+
+This variable defines Uquad_t to be something like unsigned long,
+unsigned int, unsigned long long, uint64_t, or whatever type is
+used for 64-bit integers.
+
+=item C<use5005threads>
+
+From F<usethreads.U>:
+
+This variable conditionally defines the USE_5005THREADS symbol,
+and indicates that Perl should be built to use the 5.005-based
+threading implementation. Only valid up to 5.8.x.
+
+=item C<use64bitall>
+
+From F<use64bits.U>:
+
+This variable conditionally defines the USE_64_BIT_ALL symbol,
+and indicates that 64-bit integer types should be used
+when available. The maximal possible
+64-bitness is employed: LP64 or ILP64, meaning that you will
+be able to use more than 2 gigabytes of memory. This mode is
+even more binary incompatible than USE_64_BIT_INT. You may not
+be able to run the resulting executable in a 32-bit C<CPU> at all or
+you may need at least to reboot your C<OS> to 64-bit mode.
+
+=item C<use64bitint>
+
+From F<use64bits.U>:
+
+This variable conditionally defines the USE_64_BIT_INT symbol,
+and indicates that 64-bit integer types should be used
+when available. The minimal possible 64-bitness
+is employed, just enough to get 64-bit integers into Perl.
+This may mean using for example "long longs", while your memory
+may still be limited to 2 gigabytes.
+
+=item C<usecrosscompile>
+
+From F<Cross.U>:
+
+This variable conditionally defines the C<USE_CROSS_COMPILE> symbol,
+and indicates that Perl has been cross-compiled.
+
+=item C<usedevel>
+
+From F<Devel.U>:
+
+This variable indicates that Perl was configured with development
+features enabled. This should not be done for production builds.
+
+=item C<usedl>
+
+From F<dlsrc.U>:
+
+This variable indicates if the system supports dynamic
+loading of some sort. See also dlsrc and dlobj.
+
+=item C<usedtrace>
+
+From F<usedtrace.U>:
+
+This variable indicates whether we are compiling with dtrace
+support. See also dtrace.
+
+=item C<usefaststdio>
+
+From F<usefaststdio.U>:
+
+This variable conditionally defines the C<USE_FAST_STDIO> symbol,
+and indicates that Perl should be built to use C<fast stdio>.
+Defaults to define in Perls 5.8 and earlier, to undef later.
+
+=item C<useithreads>
+
+From F<usethreads.U>:
+
+This variable conditionally defines the C<USE_ITHREADS> symbol,
+and indicates that Perl should be built to use the interpreter-based
+threading implementation.
+
+=item C<uselargefiles>
+
+From F<uselfs.U>:
+
+This variable conditionally defines the C<USE_LARGE_FILES> symbol,
+and indicates that large file interfaces should be used when
+available.
+
+=item C<uselongdouble>
+
+From F<uselongdbl.U>:
+
+This variable conditionally defines the C<USE_LONG_DOUBLE> symbol,
+and indicates that long doubles should be used when available.
+
+=item C<usemallocwrap>
+
+From F<mallocsrc.U>:
+
+This variable contains y if we are wrapping malloc to prevent
+integer overflow during size calculations.
+
+=item C<usemorebits>
+
+From F<usemorebits.U>:
+
+This variable conditionally defines the C<USE_MORE_BITS> symbol,
+and indicates that explicit 64-bit interfaces and long doubles
+should be used when available.
+
+=item C<usemultiplicity>
+
+From F<usemultiplicity.U>:
+
+This variable conditionally defines the C<MULTIPLICITY> symbol,
+and indicates that Perl should be built to use multiplicity.
+
+=item C<usemymalloc>
+
+From F<mallocsrc.U>:
+
+This variable contains y if the malloc that comes with this package
+is desired over the system's version of malloc. People often include
+special versions of malloc for effiency, but such versions are often
+less portable. See also mallocsrc and mallocobj.
+If this is C<y>, then -lmalloc is removed from $libs.
+
+=item C<usenm>
+
+From F<usenm.U>:
+
+This variable contains C<true> or C<false> depending whether the
+nm extraction is wanted or not.
+
+=item C<useopcode>
+
+From F<Extensions.U>:
+
+This variable holds either C<true> or C<false> to indicate
+whether the Opcode extension should be used. The sole
+use for this currently is to allow an easy mechanism
+for users to skip the Opcode extension from the Configure
+command line.
+
+=item C<useperlio>
+
+From F<useperlio.U>:
+
+This variable conditionally defines the C<USE_PERLIO> symbol,
+and indicates that the PerlIO abstraction should be
+used throughout.
+
+=item C<useposix>
+
+From F<Extensions.U>:
+
+This variable holds either C<true> or C<false> to indicate
+whether the C<POSIX> extension should be used. The sole
+use for this currently is to allow an easy mechanism
+for hints files to indicate that C<POSIX> will not compile
+on a particular system.
+
+=item C<usereentrant>
+
+From F<usethreads.U>:
+
+This variable conditionally defines the C<USE_REENTRANT_API> symbol,
+which indicates that the thread code may try to use the various
+_r versions of library functions. This is only potentially
+meaningful if usethreads is set and is very experimental, it is
+not even prompted for.
+
+=item C<userelocatableinc>
+
+From F<bin.U>:
+
+This variable is set to true to indicate that perl should relocate
+@C<INC> entries at runtime based on the path to the perl binary.
+Any @C<INC> paths starting F<.../> are relocated relative to the directory
+containing the perl binary, and a logical cleanup of the path is then
+made around the join point (removing F<dir/../> pairs)
+
+=item C<usesfio>
+
+From F<d_sfio.U>:
+
+This variable is set to true when the user agrees to use sfio.
+It is set to false when sfio is not available or when the user
+explicitely requests not to use sfio. It is here primarily so
+that command-line settings can override the auto-detection of
+d_sfio without running into a "WHOA THERE".
+
+=item C<useshrplib>
+
+From F<libperl.U>:
+
+This variable is set to C<true> if the user wishes
+to build a shared libperl, and C<false> otherwise.
+
+=item C<usesitecustomize>
+
+From F<d_sitecustomize.U>:
+
+This variable is set to true when the user requires a mechanism that
+allows the sysadmin to add entries to @C<INC> at runtime. This variable
+being set, makes perl run F<$F<sitelib/sitecustomize.pl>> at startup.
+
+=item C<usesocks>
+
+From F<usesocks.U>:
+
+This variable conditionally defines the C<USE_SOCKS> symbol,
+and indicates that Perl should be built to use C<SOCKS>.
+
+=item C<usethreads>
+
+From F<usethreads.U>:
+
+This variable conditionally defines the C<USE_THREADS> symbol,
+and indicates that Perl should be built to use threads.
+
+=item C<usevendorprefix>
+
+From F<vendorprefix.U>:
+
+This variable tells whether the vendorprefix
+and consequently other vendor* paths are in use.
+
+=item C<usevfork>
+
+From F<d_vfork.U>:
+
+This variable is set to true when the user accepts to use vfork.
+It is set to false when no vfork is available or when the user
+explicitely requests not to use vfork.
+
+=item C<usrinc>
+
+From F<usrinc.U>:
+
+This variable holds the path of the include files, which is
+usually F</usr/include>. It is mainly used by other Configure units.
+
+=item C<uuname>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<uvoformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<UV> as an unsigned octal integer.
+
+=item C<uvsize>
+
+From F<perlxv.U>:
+
+This variable is the size of a C<UV> in bytes.
+
+=item C<uvtype>
+
+From F<perlxv.U>:
+
+This variable contains the C type used for Perl's C<UV>.
+
+=item C<uvuformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<UV> as an unsigned decimal integer.
+
+=item C<uvxformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<UV> as an unsigned hexadecimal integer in lowercase abcdef.
+
+=item C<uvXUformat>
+
+From F<perlxvf.U>:
+
+This variable contains the format string used for printing
+a Perl C<UV> as an unsigned hexadecimal integer in uppercase C<ABCDEF>.
+
+=back
+
+=cut
+
+=head2 v
+
+=over 4
+
+=cut
+
+=item C<vaproto>
+
+From F<vaproto.U>:
+
+This variable conditionally defines C<CAN_VAPROTO> on systems supporting
+prototype declaration of functions with a variable number of
+arguments. See also prototype.
+
+=item C<vendorarch>
+
+From F<vendorarch.U>:
+
+This variable contains the value of the C<PERL_VENDORARCH> symbol.
+It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place their own
+architecture-dependent modules and extensions in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorarchexp>
+
+From F<vendorarch.U>:
+
+This variable is the F<~name> expanded version of vendorarch, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorbin>
+
+From F<vendorbin.U>:
+
+This variable contains the eventual value of the C<VENDORBIN> symbol.
+It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place additional
+binaries in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorbinexp>
+
+From F<vendorbin.U>:
+
+This variable is the F<~name> expanded version of vendorbin, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorhtml1dir>
+
+From F<vendorhtml1dir.U>:
+
+This variable contains the name of the directory for html
+pages. It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place their own
+html pages in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorhtml1direxp>
+
+From F<vendorhtml1dir.U>:
+
+This variable is the F<~name> expanded version of vendorhtml1dir, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorhtml3dir>
+
+From F<vendorhtml3dir.U>:
+
+This variable contains the name of the directory for html
+library pages. It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place their own
+html pages for modules and extensions in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorhtml3direxp>
+
+From F<vendorhtml3dir.U>:
+
+This variable is the F<~name> expanded version of vendorhtml3dir, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorlib>
+
+From F<vendorlib.U>:
+
+This variable contains the eventual value of the C<VENDORLIB> symbol,
+which is the name of the private library for this package.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place their own
+modules in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorlib_stem>
+
+From F<vendorlib.U>:
+
+This variable is $vendorlibexp with any trailing version-specific component
+removed. The elements in inc_version_list (F<inc_version_list.U>) can
+be tacked onto this variable to generate a list of directories to search.
+
+=item C<vendorlibexp>
+
+From F<vendorlib.U>:
+
+This variable is the F<~name> expanded version of vendorlib, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorman1dir>
+
+From F<vendorman1dir.U>:
+
+This variable contains the name of the directory for man1
+pages. It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place their own
+man1 pages in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorman1direxp>
+
+From F<vendorman1dir.U>:
+
+This variable is the F<~name> expanded version of vendorman1dir, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorman3dir>
+
+From F<vendorman3dir.U>:
+
+This variable contains the name of the directory for man3
+pages. It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place their own
+man3 pages in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorman3direxp>
+
+From F<vendorman3dir.U>:
+
+This variable is the F<~name> expanded version of vendorman3dir, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<vendorprefix>
+
+From F<vendorprefix.U>:
+
+This variable holds the full absolute path of the directory below
+which the vendor will install add-on packages.
+See C<INSTALL> for usage and examples.
+
+=item C<vendorprefixexp>
+
+From F<vendorprefix.U>:
+
+This variable holds the full absolute path of the directory below
+which the vendor will install add-on packages. Derived from vendorprefix.
+
+=item C<vendorscript>
+
+From F<vendorscript.U>:
+
+This variable contains the eventual value of the C<VENDORSCRIPT> symbol.
+It may have a F<~> on the front.
+The standard distribution will put nothing in this directory.
+Vendors who distribute perl may wish to place additional
+executable scripts in this directory with
+MakeMaker F<Makefile.PL> C<INSTALLDIRS>=vendor
+or equivalent. See C<INSTALL> for details.
+
+=item C<vendorscriptexp>
+
+From F<vendorscript.U>:
+
+This variable is the F<~name> expanded version of vendorscript, so that you
+may use it directly in Makefiles or shell scripts.
+
+=item C<version>
+
+From F<patchlevel.U>:
+
+The full version number of this package, such as 5.6.1 (or 5_6_1).
+This combines revision, patchlevel, and subversion to get the
+full version number, including any possible subversions.
+This is suitable for use as a directory name, and hence is
+filesystem dependent.
+
+=item C<version_patchlevel_string>
+
+From F<patchlevel.U>:
+
+This is a string combining version, subversion and
+perl_patchlevel (if perl_patchlevel is non-zero).
+It is typically something like
+'version 7 subversion 1' or
+'version 7 subversion 1 patchlevel 11224'
+It is computed here to avoid duplication of code in F<myconfig.SH>
+and F<lib/Config.pm>.
+
+=item C<versiononly>
+
+From F<versiononly.U>:
+
+If set, this symbol indicates that only the version-specific
+components of a perl installation should be installed.
+This may be useful for making a test installation of a new
+version without disturbing the existing installation.
+Setting versiononly is equivalent to setting installperl's -v option.
+In particular, the non-versioned scripts and programs such as
+a2p, c2ph, h2xs, pod2*, and perldoc are not installed
+(see C<INSTALL> for a more complete list). Nor are the man
+pages installed.
+Usually, this is undef.
+
+=item C<vi>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<voidflags>
+
+From F<voidflags.U>:
+
+This variable contains the eventual value of the C<VOIDFLAGS> symbol,
+which indicates how much support of the void type is given by this
+compiler. See C<VOIDFLAGS> for more info.
+
+=back
+
+=cut
+
+=head2 x
+
+=over 4
+
+=cut
+
+=item C<xlibpth>
+
+From F<libpth.U>:
+
+This variable holds extra path (space-separated) used to find
+libraries on this platform, for example C<CPU>-specific libraries
+(on multi-C<CPU> platforms) may be listed here.
+
+=back
+
+=cut
+
+=head2 y
+
+=over 4
+
+=cut
+
+=item C<yacc>
+
+From F<yacc.U>:
+
+This variable holds the name of the compiler compiler we
+want to use in the Makefile. It can be yacc, byacc, or bison -y.
+
+=item C<yaccflags>
+
+From F<yacc.U>:
+
+This variable contains any additional yacc flags desired by the
+user. It is up to the Makefile to use this.
+
+=back
+
+=cut
+
+=head2 z
+
+=over 4
+
+=cut
+
+=item C<zcat>
+
+From F<Loc.U>:
+
+This variable is defined but not used by Configure.
+The value is the empty string and is not useful.
+
+=item C<zip>
+
+From F<Loc.U>:
+
+This variable is used internally by Configure to determine the
+full pathname (if any) of the zip program. After Configure runs,
+the value is reset to a plain C<zip> and is not useful.
+
+
+=back
+
+=head1 GIT DATA
+
+Information on the git commit from which the current perl binary was compiled
+can be found in the variable C<$Config::Git_Data>. The variable is a
+structured string that looks something like this:
+
+ git_commit_id='ea0c2dbd5f5ac6845ecc7ec6696415bf8e27bd52'
+ git_describe='GitLive-blead-1076-gea0c2db'
+ git_branch='smartmatch'
+ git_uncommitted_changes=''
+ git_commit_id_title='Commit id:'
+ git_commit_date='2009-05-09 17:47:31 +0200'
+
+Its format is not guaranteed not to change over time.
+
+=head1 NOTE
+
+This module contains a good example of how to use tie to implement a
+cache and an example of how to make a tied variable readonly to those
+outside of it.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Config_git.pl b/Master/tlpkg/tlperl/lib/Config_git.pl
new file mode 100644
index 00000000000..6aacc4c1f4d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config_git.pl
@@ -0,0 +1,12 @@
+######################################################################
+# WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl
+# DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead
+######################################################################
+$Config::Git_Data=<<'ENDOFGIT';
+git_commit_id=''
+git_describe=''
+git_branch=''
+git_uncommitted_changes=''
+git_commit_id_title=''
+
+ENDOFGIT
diff --git a/Master/tlpkg/tlperl/lib/Config_heavy.pl b/Master/tlpkg/tlperl/lib/Config_heavy.pl
new file mode 100644
index 00000000000..57fe8aa525b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config_heavy.pl
@@ -0,0 +1,1319 @@
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+package Config;
+use strict;
+# use warnings; Pulls in Carp
+# use vars pulls in Carp
+
+sub _V {
+ my ($bincompat, $non_bincompat, $date, @patches) = Internals::V();
+
+ my $opts = join ' ', sort split ' ', "$bincompat $non_bincompat";
+
+ # wrap at 76 columns.
+
+ $opts =~ s/(?=.{53})(.{1,53}) /$1\n /mg;
+
+ print Config::myconfig();
+ if ($^O eq 'VMS') {
+ print "\nCharacteristics of this PERLSHR image: \n";
+ } else {
+ print "\nCharacteristics of this binary (from libperl): \n";
+ }
+
+ print " Compile-time options: $opts\n";
+
+ if (@patches) {
+ print " Locally applied patches:\n";
+ print "\t$_\n" foreach @patches;
+ }
+
+ print " Built under $^O\n";
+
+ print " $date\n" if defined $date;
+
+ my @env = map { "$_=\"$ENV{$_}\"" } sort grep {/^PERL/} keys %ENV;
+ push @env, "CYGWIN=\"$ENV{CYGWIN}\"" if $^O eq 'cygwin';
+
+ if (@env) {
+ print " \%ENV:\n";
+ print " $_\n" foreach @env;
+ }
+ print " \@INC:\n";
+ print " $_\n" foreach @INC;
+}
+
+### Configured by: siepo@xpeco
+### Target system: WIN32
+
+our $summary = <<'!END!';
+Summary of my $package (revision $revision $version_patchlevel_string) configuration:
+ $git_commit_id_title $git_commit_id$git_ancestor_line
+ Platform:
+ osname=$osname, osvers=$osvers, archname=$archname
+ uname='$myuname'
+ config_args='$config_args'
+ hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
+ useithreads=$useithreads, usemultiplicity=$usemultiplicity
+ useperlio=$useperlio, d_sfio=$d_sfio, uselargefiles=$uselargefiles, usesocks=$usesocks
+ use64bitint=$use64bitint, use64bitall=$use64bitall, uselongdouble=$uselongdouble
+ usemymalloc=$usemymalloc, bincompat5005=undef
+ Compiler:
+ cc='$cc', ccflags ='$ccflags',
+ optimize='$optimize',
+ cppflags='$cppflags'
+ ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers'
+ intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder
+ d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize
+ ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize
+ alignbytes=$alignbytes, prototype=$prototype
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+ libs=$libs
+ perllibs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ gnulibc_version='$gnulibc_version'
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+ cccdlflags='$cccdlflags', lddlflags='$lddlflags'
+
+!END!
+my $summary_expanded;
+
+sub myconfig {
+ return $summary_expanded if $summary_expanded;
+ ($summary_expanded = $summary) =~ s{\$(\w+)}
+ {
+ my $c;
+ if ($1 eq 'git_ancestor_line') {
+ if ($Config::Config{git_ancestor}) {
+ $c= "\n Ancestor: $Config::Config{git_ancestor}";
+ } else {
+ $c= "";
+ }
+ } else {
+ $c = $Config::Config{$1};
+ }
+ defined($c) ? $c : 'undef'
+ }ge;
+ $summary_expanded;
+}
+
+my $rootdir = __FILE__;
+$rootdir =~ s![\\/][^\\/]*[\\/][^\\/]*$!!;
+$rootdir =~ s!/!\\!g;
+
+local *_ = \my $a;
+$_ = <<"!END!";
+Author=''
+CONFIG='true'
+Date='\$Date'
+Header=''
+Id='\$Id'
+Locker=''
+Log='\$Log'
+PATCHLEVEL='12'
+PERL_API_REVISION='5'
+PERL_API_SUBVERSION='0'
+PERL_API_VERSION='12'
+PERL_CONFIG_SH='true'
+PERL_PATCHLEVEL=''
+PERL_REVISION='5'
+PERL_SUBVERSION='3'
+PERL_VERSION='12'
+RCSfile='\$RCSfile'
+Revision='\$Revision'
+SUBVERSION='3'
+Source=''
+State=''
+_a='.a'
+_exe='.exe'
+_o='.o'
+afs='false'
+afsroot='/afs'
+alignbytes='8'
+ansi2knr=''
+aphostname=''
+api_revision='5'
+api_subversion='0'
+api_version='12'
+api_versionstring='5.12.0'
+ar='ar'
+archlib='$rootdir\\lib'
+archlibexp='$rootdir\\lib'
+archname64=''
+archname='MSWin32-x86-multi-thread'
+archobjs=''
+asctime_r_proto='0'
+awk='awk'
+baserev='5'
+bash=''
+bin='$rootdir\\bin'
+binexp='$rootdir\\bin'
+bison=''
+byacc='byacc'
+byteorder='1234'
+c=''
+castflags='0'
+cat='type'
+cc='gcc'
+cccdlflags=' '
+ccdlflags=' '
+ccflags=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX'
+ccflags_uselargefiles=''
+ccname='gcc'
+ccsymbols=''
+ccversion=''
+cf_by='siepo'
+cf_email='tex-live\@tug.org'
+cf_time='Thu Feb 10 14:38:06 2011'
+charbits='8'
+chgrp=''
+chmod=''
+chown=''
+clocktype='clock_t'
+comm=''
+compress=''
+contains='grep'
+cp='copy'
+cpio=''
+cpp='gcc -E'
+cpp_stuff='42'
+cppccsymbols=''
+cppflags='-DWIN32'
+cpplast=''
+cppminus='-'
+cpprun='gcc -E'
+cppstdin='gcc -E'
+cppsymbols=''
+crypt_r_proto='0'
+cryptlib=''
+csh='undef'
+ctermid_r_proto='0'
+ctime_r_proto='0'
+d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+d_PRIEUldbl='undef'
+d_PRIFUldbl='undef'
+d_PRIGUldbl='undef'
+d_PRIXU64='undef'
+d_PRId64='undef'
+d_PRIeldbl='undef'
+d_PRIfldbl='undef'
+d_PRIgldbl='undef'
+d_PRIi64='undef'
+d_PRIo64='undef'
+d_PRIu64='undef'
+d_PRIx64='undef'
+d_SCNfldbl='undef'
+d__fwalk='undef'
+d_access='define'
+d_accessx='undef'
+d_aintl='undef'
+d_alarm='define'
+d_archlib='define'
+d_asctime64='undef'
+d_asctime_r='undef'
+d_atolf='undef'
+d_atoll='undef'
+d_attribute_deprecated='undef'
+d_attribute_format='undef'
+d_attribute_malloc='undef'
+d_attribute_nonnull='undef'
+d_attribute_noreturn='undef'
+d_attribute_pure='undef'
+d_attribute_unused='undef'
+d_attribute_warn_unused_result='undef'
+d_bcmp='undef'
+d_bcopy='undef'
+d_bsd='define'
+d_bsdgetpgrp='undef'
+d_bsdsetpgrp='undef'
+d_builtin_choose_expr='undef'
+d_builtin_expect='undef'
+d_bzero='undef'
+d_c99_variadic_macros='undef'
+d_casti32='define'
+d_castneg='define'
+d_charvspr='undef'
+d_chown='undef'
+d_chroot='undef'
+d_chsize='define'
+d_class='undef'
+d_clearenv='undef'
+d_closedir='define'
+d_cmsghdr_s='undef'
+d_const='define'
+d_copysignl='undef'
+d_cplusplus='undef'
+d_crypt='define'
+d_crypt_r='undef'
+d_csh='undef'
+d_ctermid='undef'
+d_ctermid_r='undef'
+d_ctime64='undef'
+d_ctime_r='undef'
+d_cuserid='undef'
+d_dbl_dig='define'
+d_dbminitproto='undef'
+d_difftime64='undef'
+d_difftime='define'
+d_dir_dd_fd='undef'
+d_dirfd='undef'
+d_dirnamlen='define'
+d_dlerror='define'
+d_dlopen='define'
+d_dlsymun='undef'
+d_dosuid='undef'
+d_drand48_r='undef'
+d_drand48proto='undef'
+d_dup2='define'
+d_eaccess='undef'
+d_endgrent='undef'
+d_endgrent_r='undef'
+d_endhent='undef'
+d_endhostent_r='undef'
+d_endnent='undef'
+d_endnetent_r='undef'
+d_endpent='undef'
+d_endprotoent_r='undef'
+d_endpwent='undef'
+d_endpwent_r='undef'
+d_endsent='undef'
+d_endservent_r='undef'
+d_eofnblk='define'
+d_eunice='undef'
+d_faststdio='define'
+d_fchdir='undef'
+d_fchmod='undef'
+d_fchown='undef'
+d_fcntl='undef'
+d_fcntl_can_lock='undef'
+d_fd_macros='define'
+d_fd_set='define'
+d_fds_bits='define'
+d_fgetpos='define'
+d_finite='undef'
+d_finitel='undef'
+d_flexfnam='define'
+d_flock='define'
+d_flockproto='define'
+d_fork='undef'
+d_fp_class='undef'
+d_fpathconf='undef'
+d_fpclass='undef'
+d_fpclassify='undef'
+d_fpclassl='undef'
+d_fpos64_t='undef'
+d_frexpl='undef'
+d_fs_data_s='undef'
+d_fseeko='undef'
+d_fsetpos='define'
+d_fstatfs='undef'
+d_fstatvfs='undef'
+d_fsync='undef'
+d_ftello='undef'
+d_ftime='define'
+d_futimes='undef'
+d_gdbm_ndbm_h_uses_prototypes='undef'
+d_gdbmndbm_h_uses_prototypes='undef'
+d_getaddrinfo='undef'
+d_getcwd='define'
+d_getespwnam='undef'
+d_getfsstat='undef'
+d_getgrent='undef'
+d_getgrent_r='undef'
+d_getgrgid_r='undef'
+d_getgrnam_r='undef'
+d_getgrps='undef'
+d_gethbyaddr='define'
+d_gethbyname='define'
+d_gethent='undef'
+d_gethname='define'
+d_gethostbyaddr_r='undef'
+d_gethostbyname_r='undef'
+d_gethostent_r='undef'
+d_gethostprotos='define'
+d_getitimer='undef'
+d_getlogin='define'
+d_getlogin_r='undef'
+d_getmnt='undef'
+d_getmntent='undef'
+d_getnameinfo='undef'
+d_getnbyaddr='undef'
+d_getnbyname='undef'
+d_getnent='undef'
+d_getnetbyaddr_r='undef'
+d_getnetbyname_r='undef'
+d_getnetent_r='undef'
+d_getnetprotos='undef'
+d_getpagsz='undef'
+d_getpbyname='define'
+d_getpbynumber='define'
+d_getpent='undef'
+d_getpgid='undef'
+d_getpgrp2='undef'
+d_getpgrp='undef'
+d_getppid='undef'
+d_getprior='undef'
+d_getprotobyname_r='undef'
+d_getprotobynumber_r='undef'
+d_getprotoent_r='undef'
+d_getprotoprotos='define'
+d_getprpwnam='undef'
+d_getpwent='undef'
+d_getpwent_r='undef'
+d_getpwnam_r='undef'
+d_getpwuid_r='undef'
+d_getsbyname='define'
+d_getsbyport='define'
+d_getsent='undef'
+d_getservbyname_r='undef'
+d_getservbyport_r='undef'
+d_getservent_r='undef'
+d_getservprotos='define'
+d_getspnam='undef'
+d_getspnam_r='undef'
+d_gettimeod='define'
+d_gmtime64='undef'
+d_gmtime_r='undef'
+d_gnulibc='undef'
+d_grpasswd='undef'
+d_hasmntopt='undef'
+d_htonl='define'
+d_ilogbl='undef'
+d_inc_version_list='undef'
+d_index='undef'
+d_inetaton='undef'
+d_inetntop='undef'
+d_inetpton='undef'
+d_int64_t='undef'
+d_isascii='define'
+d_isfinite='undef'
+d_isinf='undef'
+d_isnan='define'
+d_isnanl='undef'
+d_killpg='define'
+d_lchown='undef'
+d_ldbl_dig='define'
+d_libm_lib_version='undef'
+d_link='define'
+d_localtime64='undef'
+d_localtime_r='undef'
+d_localtime_r_needs_tzset='undef'
+d_locconv='define'
+d_lockf='undef'
+d_longdbl='define'
+d_longlong='undef'
+d_lseekproto='define'
+d_lstat='undef'
+d_madvise='undef'
+d_malloc_good_size='undef'
+d_malloc_size='undef'
+d_mblen='define'
+d_mbstowcs='define'
+d_mbtowc='define'
+d_memchr='define'
+d_memcmp='define'
+d_memcpy='define'
+d_memmove='define'
+d_memset='define'
+d_mkdir='define'
+d_mkdtemp='undef'
+d_mkfifo='undef'
+d_mkstemp='undef'
+d_mkstemps='undef'
+d_mktime64='undef'
+d_mktime='define'
+d_mmap='undef'
+d_modfl='undef'
+d_modfl_pow32_bug='undef'
+d_modflproto='undef'
+d_mprotect='undef'
+d_msg='undef'
+d_msg_ctrunc='undef'
+d_msg_dontroute='undef'
+d_msg_oob='undef'
+d_msg_peek='undef'
+d_msg_proxy='undef'
+d_msgctl='undef'
+d_msgget='undef'
+d_msghdr_s='undef'
+d_msgrcv='undef'
+d_msgsnd='undef'
+d_msync='undef'
+d_munmap='undef'
+d_mymalloc='undef'
+d_ndbm='undef'
+d_ndbm_h_uses_prototypes='undef'
+d_nice='undef'
+d_nl_langinfo='undef'
+d_nv_preserves_uv='define'
+d_nv_zero_is_allbits_zero='define'
+d_off64_t='undef'
+d_old_pthread_create_joinable='undef'
+d_oldpthreads='undef'
+d_oldsock='undef'
+d_open3='undef'
+d_pathconf='undef'
+d_pause='define'
+d_perl_otherlibdirs='undef'
+d_phostname='undef'
+d_pipe='define'
+d_poll='undef'
+d_portable='define'
+d_printf_format_null='undef'
+d_procselfexe='undef'
+d_pseudofork='define'
+d_pthread_atfork='undef'
+d_pthread_attr_setscope='undef'
+d_pthread_yield='undef'
+d_pwage='undef'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwcomment='undef'
+d_pwexpire='undef'
+d_pwgecos='undef'
+d_pwpasswd='undef'
+d_pwquota='undef'
+d_qgcvt='undef'
+d_quad='define'
+d_random_r='undef'
+d_readdir64_r='undef'
+d_readdir='define'
+d_readdir_r='undef'
+d_readlink='undef'
+d_readv='undef'
+d_recvmsg='undef'
+d_rename='define'
+d_rewinddir='define'
+d_rmdir='define'
+d_safebcpy='undef'
+d_safemcpy='undef'
+d_sanemcmp='define'
+d_sbrkproto='undef'
+d_scalbnl='undef'
+d_sched_yield='undef'
+d_scm_rights='undef'
+d_seekdir='define'
+d_select='define'
+d_sem='undef'
+d_semctl='undef'
+d_semctl_semid_ds='undef'
+d_semctl_semun='undef'
+d_semget='undef'
+d_semop='undef'
+d_sendmsg='undef'
+d_setegid='undef'
+d_seteuid='undef'
+d_setgrent='undef'
+d_setgrent_r='undef'
+d_setgrps='undef'
+d_sethent='undef'
+d_sethostent_r='undef'
+d_setitimer='undef'
+d_setlinebuf='undef'
+d_setlocale='define'
+d_setlocale_r='undef'
+d_setnent='undef'
+d_setnetent_r='undef'
+d_setpent='undef'
+d_setpgid='undef'
+d_setpgrp2='undef'
+d_setpgrp='undef'
+d_setprior='undef'
+d_setproctitle='undef'
+d_setprotoent_r='undef'
+d_setpwent='undef'
+d_setpwent_r='undef'
+d_setregid='undef'
+d_setresgid='undef'
+d_setresuid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+d_setsent='undef'
+d_setservent_r='undef'
+d_setsid='undef'
+d_setvbuf='define'
+d_sfio='undef'
+d_shm='undef'
+d_shmat='undef'
+d_shmatprototype='undef'
+d_shmctl='undef'
+d_shmdt='undef'
+d_shmget='undef'
+d_sigaction='undef'
+d_signbit='undef'
+d_sigprocmask='undef'
+d_sigsetjmp='undef'
+d_sitearch='define'
+d_snprintf='define'
+d_sockatmark='undef'
+d_sockatmarkproto='undef'
+d_socket='define'
+d_socklen_t='undef'
+d_sockpair='undef'
+d_socks5_init='undef'
+d_sprintf_returns_strlen='define'
+d_sqrtl='undef'
+d_srand48_r='undef'
+d_srandom_r='undef'
+d_sresgproto='undef'
+d_sresuproto='undef'
+d_statblks='undef'
+d_statfs_f_flags='undef'
+d_statfs_s='undef'
+d_statvfs='undef'
+d_stdio_cnt_lval='define'
+d_stdio_ptr_lval='define'
+d_stdio_ptr_lval_nochange_cnt='define'
+d_stdio_ptr_lval_sets_cnt='undef'
+d_stdio_stream_array='undef'
+d_stdiobase='define'
+d_stdstdio='define'
+d_strchr='define'
+d_strcoll='define'
+d_strctcpy='define'
+d_strerrm='strerror(e)'
+d_strerror='define'
+d_strerror_r='undef'
+d_strftime='define'
+d_strlcat='undef'
+d_strlcpy='undef'
+d_strtod='define'
+d_strtol='define'
+d_strtold='undef'
+d_strtoll='undef'
+d_strtoq='undef'
+d_strtoul='define'
+d_strtoull='undef'
+d_strtouq='undef'
+d_strxfrm='define'
+d_suidsafe='undef'
+d_symlink='undef'
+d_syscall='undef'
+d_syscallproto='undef'
+d_sysconf='undef'
+d_sysernlst=''
+d_syserrlst='define'
+d_system='define'
+d_tcgetpgrp='undef'
+d_tcsetpgrp='undef'
+d_telldir='define'
+d_telldirproto='define'
+d_time='define'
+d_timegm='undef'
+d_times='define'
+d_tm_tm_gmtoff='undef'
+d_tm_tm_zone='undef'
+d_tmpnam_r='undef'
+d_truncate='undef'
+d_ttyname_r='undef'
+d_tzname='define'
+d_u32align='define'
+d_ualarm='undef'
+d_umask='define'
+d_uname='define'
+d_union_semun='define'
+d_unordered='undef'
+d_unsetenv='undef'
+d_usleep='undef'
+d_usleepproto='undef'
+d_ustat='undef'
+d_vendorarch='undef'
+d_vendorbin='undef'
+d_vendorlib='undef'
+d_vendorscript='undef'
+d_vfork='undef'
+d_void_closedir='undef'
+d_voidsig='define'
+d_voidtty=''
+d_volatile='define'
+d_vprintf='define'
+d_vsnprintf='define'
+d_wait4='undef'
+d_waitpid='define'
+d_wcstombs='define'
+d_wctomb='define'
+d_writev='undef'
+d_xenix='undef'
+date='date'
+db_hashtype='int'
+db_prefixtype='int'
+db_version_major='0'
+db_version_minor='0'
+db_version_patch='0'
+defvoidused='15'
+direntrytype='struct direct'
+dlext='dll'
+dlsrc='dl_win32.xs'
+doublesize='8'
+drand01='(rand()/(double)((unsigned)1<<RANDBITS))'
+drand48_r_proto='0'
+dtrace=''
+dynamic_ext='B Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call Hash/Util Hash/Util/FieldHash IO List/Util MIME/Base64 Math/BigInt/FastCalc Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Text/Soundex Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes mro re threads threads/shared'
+eagain='EAGAIN'
+ebcdic='undef'
+echo='echo'
+egrep='egrep'
+emacs=''
+endgrent_r_proto='0'
+endhostent_r_proto='0'
+endnetent_r_proto='0'
+endprotoent_r_proto='0'
+endpwent_r_proto='0'
+endservent_r_proto='0'
+eunicefix=':'
+exe_ext='.exe'
+expr='expr'
+extensions='Archive/Extract Archive/Tar Attribute/Handlers AutoLoader B B/Debug B/Deparse B/Lint CGI CPAN CPANPLUS CPANPLUS/Dist/Build Class/ISA Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Devel/SelfStubber Digest Digest/MD5 Digest/SHA Encode Errno ExtUtils/CBuilder ExtUtils/Command ExtUtils/Constant ExtUtils/Install ExtUtils/MakeMaker ExtUtils/Manifest ExtUtils/ParseXS Fcntl File/Fetch File/Glob File/Path File/Temp FileCache Filter/Simple Filter/Util/Call Getopt/Long Hash/Util Hash/Util/FieldHash I18N/LangTags IO IO/Compress IO/Zlib IPC/Cmd IPC/Open2 IPC/Open3 List/Util Locale/Codes Locale/Maketext Locale/Maketext/Simple Log/Message Log/Message/Simple MIME/Base64 Math/BigInt Math/BigInt/FastCalc Math/BigRat Math/Complex Memoize Module/Build Module/CoreList Module/Load Module/Load/Conditional Module/Loaded Module/Pluggable NEXT Net/Ping Object/Accessor Opcode POSIX Package/Constants Params/Check Parse/CPAN/Meta PerlIO/encoding PerlIO/scalar PerlIO/via PerlIO/via/QuotedPrint Pod/Escapes Pod/LaTeX Pod/Parser Pod/Perldoc Pod/Plainer Pod/Simple SDBM_File Safe SelfLoader Shell Socket Storable Switch Sys/Hostname Term/ANSIColor Term/Cap Term/UI Test Test/Harness Test/Simple Text/Balanced Text/ParseWords Text/Soundex Text/Tabs Thread/Queue Thread/Semaphore Tie/File Tie/Memoize Tie/RefHash Time/HiRes Time/Local Time/Piece Unicode/Collate Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap XSLoader attributes autodie autouse base bignum constant encoding/warnings if lib libnet mro parent podlators re threads threads/shared'
+extern_C='extern'
+extras=''
+fflushNULL='define'
+fflushall='undef'
+find='find'
+firstmakefile='makefile'
+flex=''
+fpossize='8'
+fpostype='fpos_t'
+freetype='void'
+from=':'
+full_ar=''
+full_csh=''
+full_sed=''
+gccansipedantic=''
+gccosandvers=''
+gccversion='4.5.0'
+getgrent_r_proto='0'
+getgrgid_r_proto='0'
+getgrnam_r_proto='0'
+gethostbyaddr_r_proto='0'
+gethostbyname_r_proto='0'
+gethostent_r_proto='0'
+getlogin_r_proto='0'
+getnetbyaddr_r_proto='0'
+getnetbyname_r_proto='0'
+getnetent_r_proto='0'
+getprotobyname_r_proto='0'
+getprotobynumber_r_proto='0'
+getprotoent_r_proto='0'
+getpwent_r_proto='0'
+getpwnam_r_proto='0'
+getpwuid_r_proto='0'
+getservbyname_r_proto='0'
+getservbyport_r_proto='0'
+getservent_r_proto='0'
+getspnam_r_proto='0'
+gidformat='"ld"'
+gidsign='-1'
+gidsize='4'
+gidtype='gid_t'
+glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib '
+gmake='gmake'
+gmtime_r_proto='0'
+gnulibc_version=''
+grep='grep'
+groupcat=''
+groupstype='gid_t'
+gzip='gzip'
+h_fcntl='false'
+h_sysfile='true'
+hint='recommended'
+hostcat='ypcat hosts'
+html1dir=' '
+html1direxp=''
+html3dir=' '
+html3direxp=''
+i16size='2'
+i16type='short'
+i32size='4'
+i32type='long'
+i64size='8'
+i64type='long long'
+i8size='1'
+i8type='char'
+i_arpainet='define'
+i_assert='define'
+i_bsdioctl=''
+i_crypt='undef'
+i_db='undef'
+i_dbm='undef'
+i_dirent='define'
+i_dld='undef'
+i_dlfcn='define'
+i_fcntl='define'
+i_float='define'
+i_fp='undef'
+i_fp_class='undef'
+i_gdbm='undef'
+i_gdbm_ndbm='undef'
+i_gdbmndbm='undef'
+i_grp='undef'
+i_ieeefp='undef'
+i_inttypes='undef'
+i_langinfo='undef'
+i_libutil='undef'
+i_limits='define'
+i_locale='define'
+i_machcthr='undef'
+i_malloc='define'
+i_mallocmalloc='undef'
+i_math='define'
+i_memory='undef'
+i_mntent='undef'
+i_ndbm='undef'
+i_netdb='undef'
+i_neterrno='undef'
+i_netinettcp='undef'
+i_niin='undef'
+i_poll='undef'
+i_prot='undef'
+i_pthread='undef'
+i_pwd='undef'
+i_rpcsvcdbm='define'
+i_sfio='undef'
+i_sgtty='undef'
+i_shadow='undef'
+i_socks='undef'
+i_stdarg='define'
+i_stddef='define'
+i_stdlib='define'
+i_string='define'
+i_sunmath='undef'
+i_sysaccess='undef'
+i_sysdir='undef'
+i_sysfile='undef'
+i_sysfilio='define'
+i_sysin='undef'
+i_sysioctl='undef'
+i_syslog='undef'
+i_sysmman='undef'
+i_sysmode='undef'
+i_sysmount='undef'
+i_sysndir='undef'
+i_sysparam='undef'
+i_syspoll='undef'
+i_sysresrc='undef'
+i_syssecrt='undef'
+i_sysselct='undef'
+i_syssockio='undef'
+i_sysstat='define'
+i_sysstatfs='undef'
+i_sysstatvfs='undef'
+i_systime='undef'
+i_systimek='undef'
+i_systimes='undef'
+i_systypes='define'
+i_sysuio='undef'
+i_sysun='undef'
+i_sysutsname='undef'
+i_sysvfs='undef'
+i_syswait='undef'
+i_termio='undef'
+i_termios='undef'
+i_time='define'
+i_unistd='undef'
+i_ustat='undef'
+i_utime='define'
+i_values='undef'
+i_varargs='undef'
+i_varhdr='varargs.h'
+i_vfork='undef'
+ignore_versioned_solibs=''
+inc_version_list=''
+inc_version_list_init='0'
+incpath='X:\\mingw32\\include'
+inews=''
+initialinstalllocation=''
+installarchlib='$rootdir\\lib'
+installbin='$rootdir\\bin'
+installhtml1dir=''
+installhtml3dir=''
+installhtmldir='$rootdir\\html'
+installhtmlhelpdir='$rootdir\\htmlhelp'
+installman1dir='$rootdir\\man\\man1'
+installman3dir='$rootdir\\man\\man3'
+installprefix='$rootdir'
+installprefixexp='$rootdir'
+installprivlib='$rootdir\\lib'
+installscript='$rootdir\\bin'
+installsitearch='$rootdir\\site\\lib'
+installsitebin='$rootdir\\bin'
+installsitehtml1dir=''
+installsitehtml3dir=''
+installsitelib='$rootdir\\site\\lib'
+installsiteman1dir=''
+installsiteman3dir=''
+installsitescript=''
+installstyle='lib'
+installusrbinperl='undef'
+installvendorarch=''
+installvendorbin=''
+installvendorhtml1dir=''
+installvendorhtml3dir=''
+installvendorlib=''
+installvendorman1dir=''
+installvendorman3dir=''
+installvendorscript=''
+intsize='4'
+issymlink=''
+ivdformat='"ld"'
+ivsize='4'
+ivtype='long'
+known_extensions='B Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util Hash/Util/FieldHash I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Math/BigInt/FastCalc NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex Time/HiRes Time/Piece Unicode/Normalize VMS/DCLsym VMS/Stdio Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes mro re threads threads/shared'
+ksh=''
+ld='g++'
+lddlflags='-mdll -s -L"$rootdir\\lib\\CORE" -L"X:\\mingw32\\lib"'
+ldflags='-s -L"$rootdir\\lib\\CORE" -L"X:\\mingw32\\lib"'
+ldflags_uselargefiles=''
+ldlibpthname=''
+less='less'
+lib_ext='.a'
+libc=''
+libperl='libperl512.a'
+libpth='X:\\mingw32\\lib'
+libs='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32'
+libsdirs=''
+libsfiles=''
+libsfound=''
+libspath=''
+libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+libswanted_uselargefiles='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+line='line'
+lint=''
+lkflags=''
+ln=''
+lns='copy'
+localtime_r_proto='0'
+locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+longdblsize='12'
+longlongsize='8'
+longsize='4'
+lp=''
+lpr=''
+ls='dir'
+lseeksize='8'
+lseektype='long long'
+mad='undef'
+madlyh=''
+madlyobj=''
+madlysrc=''
+mail=''
+mailx=''
+make='dmake'
+make_set_make='#'
+mallocobj='malloc.o'
+mallocsrc='malloc.c'
+malloctype='void *'
+man1dir='$rootdir\\man\\man1'
+man1direxp='$rootdir\\man\\man1'
+man1ext='1'
+man3dir='$rootdir\\man\\man3'
+man3direxp='$rootdir\\man\\man3'
+man3ext='3'
+mips_type=''
+mistrustnm=''
+mkdir='mkdir'
+mmaptype='void *'
+modetype='mode_t'
+more='more /e'
+multiarch='undef'
+mv=''
+myarchname='MSWin32'
+mydomain=''
+myhostname=''
+myuname=''
+n='-n'
+need_va_copy='undef'
+netdb_hlen_type='int'
+netdb_host_type='char *'
+netdb_name_type='char *'
+netdb_net_type='long'
+nm='nm'
+nm_opt=''
+nm_so_opt=''
+nonxs_ext='Archive/Extract Archive/Tar Attribute/Handlers AutoLoader B/Debug B/Deparse B/Lint CGI CPAN CPANPLUS CPANPLUS/Dist/Build Class/ISA Devel/SelfStubber Digest Errno ExtUtils/CBuilder ExtUtils/Command ExtUtils/Constant ExtUtils/Install ExtUtils/MakeMaker ExtUtils/Manifest ExtUtils/ParseXS File/Fetch File/Path File/Temp FileCache Filter/Simple Getopt/Long I18N/LangTags IO/Compress IO/Zlib IPC/Cmd IPC/Open2 IPC/Open3 Locale/Codes Locale/Maketext Locale/Maketext/Simple Log/Message Log/Message/Simple Math/BigInt Math/BigRat Math/Complex Memoize Module/Build Module/CoreList Module/Load Module/Load/Conditional Module/Loaded Module/Pluggable NEXT Net/Ping Object/Accessor Package/Constants Params/Check Parse/CPAN/Meta PerlIO/via/QuotedPrint Pod/Escapes Pod/LaTeX Pod/Parser Pod/Perldoc Pod/Plainer Pod/Simple Safe SelfLoader Shell Switch Term/ANSIColor Term/Cap Term/UI Test Test/Harness Test/Simple Text/Balanced Text/ParseWords Text/Tabs Thread/Queue Thread/Semaphore Tie/File Tie/Memoize Tie/RefHash Time/Local Unicode/Collate XSLoader autodie autouse base bignum constant encoding/warnings if lib libnet parent podlators'
+nroff=''
+nvEUformat='"E"'
+nvFUformat='"F"'
+nvGUformat='"G"'
+nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0'
+nv_preserves_uv_bits='32'
+nveformat='"e"'
+nvfformat='"f"'
+nvgformat='"g"'
+nvsize='8'
+nvtype='double'
+o_nonblock='O_NONBLOCK'
+obj_ext='.o'
+old_pthread_create_joinable=''
+optimize='-s -O2'
+orderlib='false'
+osname='MSWin32'
+osvers='5.1'
+otherlibdirs=''
+package='perl5'
+pager='more /e'
+passcat=''
+patchlevel='12'
+path_sep=';'
+perl5=''
+perl='perl'
+perl_patchlevel=''
+perladmin=''
+perllibs='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32'
+perlpath='$rootdir\\bin\\perl.exe'
+pg=''
+phostname='hostname'
+pidtype='int'
+plibpth=''
+pmake=''
+pr=''
+prefix='$rootdir'
+prefixexp='$rootdir'
+privlib='$rootdir\\lib'
+privlibexp='$rootdir\\lib'
+procselfexe=''
+prototype='define'
+ptrsize='4'
+quadkind='3'
+quadtype='long long'
+randbits='15'
+randfunc='rand'
+random_r_proto='0'
+randseedtype='unsigned'
+ranlib='rem'
+rd_nodata='-1'
+readdir64_r_proto='0'
+readdir_r_proto='0'
+revision='5'
+rm='del'
+rm_try=''
+rmail=''
+run=''
+runnm='true'
+sGMTIME_max="2147483647"
+sGMTIME_min="0"
+sLOCALTIME_max="2147483647"
+sLOCALTIME_min="0"
+sPRIEUldbl='"E"'
+sPRIFUldbl='"F"'
+sPRIGUldbl='"G"'
+sPRIXU64='"lX"'
+sPRId64='"ld"'
+sPRIeldbl='"e"'
+sPRIfldbl='"f"'
+sPRIgldbl='"g"'
+sPRIi64='"li"'
+sPRIo64='"lo"'
+sPRIu64='"lu"'
+sPRIx64='"lx"'
+sSCNfldbl='"f"'
+sched_yield=''
+scriptdir='$rootdir\\bin'
+scriptdirexp='$rootdir\\bin'
+sed='sed'
+seedfunc='srand'
+selectminbits='32'
+selecttype='Perl_fd_set *'
+sendmail='blat'
+setgrent_r_proto='0'
+sethostent_r_proto='0'
+setlocale_r_proto='0'
+setnetent_r_proto='0'
+setprotoent_r_proto='0'
+setpwent_r_proto='0'
+setservent_r_proto='0'
+sh='cmd /x /c'
+shar=''
+sharpbang='#!'
+shmattype='void *'
+shortsize='2'
+shrpenv=''
+shsharp='true'
+sig_count='26'
+sig_name='ZERO HUP INT QUIT ILL NUM05 NUM06 NUM07 FPE KILL NUM10 SEGV NUM12 PIPE ALRM TERM NUM16 NUM17 NUM18 NUM19 CHLD BREAK ABRT STOP NUM24 CONT CLD'
+sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0'
+sig_num='0 1 2 21 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20'
+sig_num_init='0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0'
+sig_size='27'
+signal_t='void'
+sitearch='$rootdir\\site\\lib'
+sitearchexp='$rootdir\\site\\lib'
+sitebin='$rootdir\\site\\bin'
+sitebinexp='$rootdir\\site\\bin'
+sitehtml1dir=''
+sitehtml1direxp=''
+sitehtml3dir=''
+sitehtml3direxp=''
+sitelib='$rootdir\\site\\lib'
+sitelib_stem=''
+sitelibexp='$rootdir\\site\\lib'
+siteman1dir=''
+siteman1direxp=''
+siteman3dir=''
+siteman3direxp=''
+siteprefix='$rootdir\\site'
+siteprefixexp='$rootdir\\site'
+sitescript=''
+sitescriptexp=''
+sizesize='4'
+sizetype='size_t'
+sleep=''
+smail=''
+so='dll'
+sockethdr=''
+socketlib=''
+socksizetype='int'
+sort='sort'
+spackage='Perl5'
+spitshell=''
+srand48_r_proto='0'
+srandom_r_proto='0'
+src=''
+ssizetype='int'
+startperl='#!perl'
+startsh='#!/bin/sh'
+static_ext='Win32CORE'
+stdchar='char'
+stdio_base='((fp)->_base)'
+stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
+stdio_cnt='((fp)->_cnt)'
+stdio_filbuf=''
+stdio_ptr='((fp)->_ptr)'
+stdio_stream_array=''
+strerror_r_proto='0'
+strings='/usr/include/string.h'
+submit=''
+subversion=''
+sysman='/usr/man/man1'
+tail=''
+tar=''
+targetarch=''
+tbl=''
+tee=''
+test=''
+timeincl='/usr/include/sys/time.h '
+timetype='time_t'
+tmpnam_r_proto='0'
+to=':'
+touch='touch'
+tr=''
+trnl='\\012'
+troff=''
+ttyname_r_proto='0'
+u16size='2'
+u16type='unsigned short'
+u32size='4'
+u32type='unsigned long'
+u64size='8'
+u64type='unsigned long long'
+u8size='1'
+u8type='unsigned char'
+uidformat='"ld"'
+uidsign='-1'
+uidsize='4'
+uidtype='uid_t'
+uname='uname'
+uniq='uniq'
+uquadtype='unsigned long long'
+use5005threads='undef'
+use64bitall='undef'
+use64bitint='undef'
+usecrosscompile='undef'
+usedevel='undef'
+usedl='define'
+usedtrace='undef'
+usefaststdio='undef'
+useithreads='define'
+uselargefiles='define'
+uselongdouble='undef'
+usemallocwrap='define'
+usemorebits='undef'
+usemultiplicity='define'
+usemymalloc='n'
+usenm='false'
+useopcode='true'
+useperlio='define'
+useposix='true'
+usereentrant='undef'
+userelocatableinc='undef'
+usesfio='false'
+useshrplib='true'
+usesitecustomize='undef'
+usesocks='undef'
+usethreads='define'
+usevendorprefix='undef'
+usevfork='false'
+usrinc='/usr/include'
+uuname=''
+uvXUformat='"lX"'
+uvoformat='"lo"'
+uvsize='4'
+uvtype='unsigned long'
+uvuformat='"lu"'
+uvxformat='"lx"'
+vaproto='undef'
+vendorarch=''
+vendorarchexp=''
+vendorbin=''
+vendorbinexp=''
+vendorhtml1dir=' '
+vendorhtml1direxp=''
+vendorhtml3dir=' '
+vendorhtml3direxp=''
+vendorlib=''
+vendorlib_stem=''
+vendorlibexp=''
+vendorman1dir=' '
+vendorman1direxp=''
+vendorman3dir=' '
+vendorman3direxp=''
+vendorprefix=''
+vendorprefixexp=''
+vendorscript=''
+vendorscriptexp=''
+version='5.12.3'
+version_patchlevel_string='version 12 subversion 3'
+versiononly='undef'
+vi=''
+voidflags='15'
+xlibpth='/usr/lib/386 /lib/386'
+yacc='yacc'
+yaccflags=''
+zcat=''
+zip='zip'
+!END!
+
+my $i = 0;
+foreach my $c (4,3,2) { $i |= ord($c); $i <<= 8 }
+$i |= ord(1);
+our $byteorder = join('', unpack('aaaa', pack('L!', $i)));
+s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
+
+my $config_sh_len = length $_;
+
+our $Config_SH_expanded = "\n$_" . << "EOVIRTUAL";
+ccflags_nolargefiles=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX'
+ldflags_nolargefiles='-s -L"$rootdir\\lib\\CORE" -L"X:\\mingw32\\lib"'
+libs_nolargefiles='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32'
+libswanted_nolargefiles=''
+EOVIRTUAL
+eval {
+ # do not have hairy conniptions if this isnt available
+ require 'Config_git.pl';
+ $Config_SH_expanded .= $Config::Git_Data;
+ 1;
+} or warn "Warning: failed to load Config_git.pl, something strange about this perl...\n";
+
+# Search for it in the big string
+sub fetch_string {
+ my($self, $key) = @_;
+
+ my $quote_type = "'";
+ my $marker = "$key=";
+
+ # Check for the common case, ' delimited
+ my $start = index($Config_SH_expanded, "\n$marker$quote_type");
+ # If that failed, check for " delimited
+ if ($start == -1) {
+ $quote_type = '"';
+ $start = index($Config_SH_expanded, "\n$marker$quote_type");
+ }
+ # Start can never be -1 now, as we've rigged the long string we're
+ # searching with an initial dummy newline.
+ return undef if $start == -1;
+
+ $start += length($key) + 3;
+
+ my $value = substr($Config_SH_expanded, $start,
+ index($Config_SH_expanded, "$quote_type\n", $start)
+ - $start);
+
+ # If we had a double-quote, we'd better eval it so escape
+ # sequences and such can be interpolated. Since the incoming
+ # value is supposed to follow shell rules and not perl rules,
+ # we escape any perl variable markers
+ if ($quote_type eq '"') {
+ $value =~ s/\$/\\\$/g;
+ $value =~ s/\@/\\\@/g;
+ eval "\$value = \"$value\"";
+ }
+ # So we can say "if $Config{'foo'}".
+ $value = undef if $value eq 'undef';
+ $self->{$key} = $value; # cache it
+}
+
+my $prevpos = 0;
+
+sub FIRSTKEY {
+ $prevpos = 0;
+ substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
+}
+
+sub NEXTKEY {
+ # Find out how the current key's quoted so we can skip to its end.
+ my $quote = substr($Config_SH_expanded,
+ index($Config_SH_expanded, "=", $prevpos)+1, 1);
+ my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
+ my $len = index($Config_SH_expanded, "=", $pos) - $pos;
+ $prevpos = $pos;
+ $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
+}
+
+sub EXISTS {
+ return 1 if exists($_[0]->{$_[1]});
+
+ return(index($Config_SH_expanded, "\n$_[1]='") != -1
+ or index($Config_SH_expanded, "\n$_[1]=\"") != -1
+ );
+}
+
+sub STORE { die "\%Config::Config is read-only\n" }
+*DELETE = \&STORE;
+*CLEAR = \&STORE;
+
+
+sub config_sh {
+ substr $Config_SH_expanded, 1, $config_sh_len;
+}
+
+sub config_re {
+ my $re = shift;
+ return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
+ $Config_SH_expanded;
+}
+
+sub config_vars {
+ # implements -V:cfgvar option (see perlrun -V:)
+ foreach (@_) {
+ # find optional leading, trailing colons; and query-spec
+ my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft,
+ # map colon-flags to print decorations
+ my $prfx = $notag ? '': "$qry="; # tag-prefix for print
+ my $lnend = $lncont ? ' ' : ";\n"; # line ending for print
+
+ # all config-vars are by definition \w only, any \W means regex
+ if ($qry =~ /\W/) {
+ my @matches = config_re($qry);
+ print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag;
+ print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag;
+ } else {
+ my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
+ : 'UNKNOWN';
+ $v = 'undef' unless defined $v;
+ print "${prfx}'${v}'$lnend";
+ }
+ }
+}
+
+# Called by the real AUTOLOAD
+sub launcher {
+ undef &AUTOLOAD;
+ goto \&$Config::AUTOLOAD;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Config_heavy.plold b/Master/tlpkg/tlperl/lib/Config_heavy.plold
new file mode 100644
index 00000000000..bf76b2a11b7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Config_heavy.plold
@@ -0,0 +1,1315 @@
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+package Config;
+use strict;
+# use warnings; Pulls in Carp
+# use vars pulls in Carp
+
+sub _V {
+ my ($bincompat, $non_bincompat, $date, @patches) = Internals::V();
+
+ my $opts = join ' ', sort split ' ', "$bincompat $non_bincompat";
+
+ # wrap at 76 columns.
+
+ $opts =~ s/(?=.{53})(.{1,53}) /$1\n /mg;
+
+ print Config::myconfig();
+ if ($^O eq 'VMS') {
+ print "\nCharacteristics of this PERLSHR image: \n";
+ } else {
+ print "\nCharacteristics of this binary (from libperl): \n";
+ }
+
+ print " Compile-time options: $opts\n";
+
+ if (@patches) {
+ print " Locally applied patches:\n";
+ print "\t$_\n" foreach @patches;
+ }
+
+ print " Built under $^O\n";
+
+ print " $date\n" if defined $date;
+
+ my @env = map { "$_=\"$ENV{$_}\"" } sort grep {/^PERL/} keys %ENV;
+ push @env, "CYGWIN=\"$ENV{CYGWIN}\"" if $^O eq 'cygwin';
+
+ if (@env) {
+ print " \%ENV:\n";
+ print " $_\n" foreach @env;
+ }
+ print " \@INC:\n";
+ print " $_\n" foreach @INC;
+}
+
+### Configured by: siepo@xpeco
+### Target system: WIN32
+
+our $summary = <<'!END!';
+Summary of my $package (revision $revision $version_patchlevel_string) configuration:
+ $git_commit_id_title $git_commit_id$git_ancestor_line
+ Platform:
+ osname=$osname, osvers=$osvers, archname=$archname
+ uname='$myuname'
+ config_args='$config_args'
+ hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
+ useithreads=$useithreads, usemultiplicity=$usemultiplicity
+ useperlio=$useperlio, d_sfio=$d_sfio, uselargefiles=$uselargefiles, usesocks=$usesocks
+ use64bitint=$use64bitint, use64bitall=$use64bitall, uselongdouble=$uselongdouble
+ usemymalloc=$usemymalloc, bincompat5005=undef
+ Compiler:
+ cc='$cc', ccflags ='$ccflags',
+ optimize='$optimize',
+ cppflags='$cppflags'
+ ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers'
+ intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder
+ d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize
+ ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize
+ alignbytes=$alignbytes, prototype=$prototype
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+ libs=$libs
+ perllibs=$perllibs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ gnulibc_version='$gnulibc_version'
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+ cccdlflags='$cccdlflags', lddlflags='$lddlflags'
+
+!END!
+my $summary_expanded;
+
+sub myconfig {
+ return $summary_expanded if $summary_expanded;
+ ($summary_expanded = $summary) =~ s{\$(\w+)}
+ {
+ my $c;
+ if ($1 eq 'git_ancestor_line') {
+ if ($Config::Config{git_ancestor}) {
+ $c= "\n Ancestor: $Config::Config{git_ancestor}";
+ } else {
+ $c= "";
+ }
+ } else {
+ $c = $Config::Config{$1};
+ }
+ defined($c) ? $c : 'undef'
+ }ge;
+ $summary_expanded;
+}
+
+local *_ = \my $a;
+$_ = <<'!END!';
+Author=''
+CONFIG='true'
+Date='$Date'
+Header=''
+Id='$Id'
+Locker=''
+Log='$Log'
+PATCHLEVEL='12'
+PERL_API_REVISION='5'
+PERL_API_SUBVERSION='0'
+PERL_API_VERSION='12'
+PERL_CONFIG_SH='true'
+PERL_PATCHLEVEL=''
+PERL_REVISION='5'
+PERL_SUBVERSION='3'
+PERL_VERSION='12'
+RCSfile='$RCSfile'
+Revision='$Revision'
+SUBVERSION='3'
+Source=''
+State=''
+_a='.a'
+_exe='.exe'
+_o='.o'
+afs='false'
+afsroot='/afs'
+alignbytes='8'
+ansi2knr=''
+aphostname=''
+api_revision='5'
+api_subversion='0'
+api_version='12'
+api_versionstring='5.12.0'
+ar='ar'
+archlib='c:\perl\lib'
+archlibexp='c:\perl\lib'
+archname64=''
+archname='MSWin32-x86-multi-thread'
+archobjs=''
+asctime_r_proto='0'
+awk='awk'
+baserev='5'
+bash=''
+bin='c:\perl\bin'
+binexp='c:\perl\bin'
+bison=''
+byacc='byacc'
+byteorder='1234'
+c=''
+castflags='0'
+cat='type'
+cc='gcc'
+cccdlflags=' '
+ccdlflags=' '
+ccflags=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX'
+ccflags_uselargefiles=''
+ccname='gcc'
+ccsymbols=''
+ccversion=''
+cf_by='siepo'
+cf_email='siepo@xpeco'
+cf_time='Thu Feb 10 14:38:06 2011'
+charbits='8'
+chgrp=''
+chmod=''
+chown=''
+clocktype='clock_t'
+comm=''
+compress=''
+contains='grep'
+cp='copy'
+cpio=''
+cpp='gcc -E'
+cpp_stuff='42'
+cppccsymbols=''
+cppflags='-DWIN32'
+cpplast=''
+cppminus='-'
+cpprun='gcc -E'
+cppstdin='gcc -E'
+cppsymbols=''
+crypt_r_proto='0'
+cryptlib=''
+csh='undef'
+ctermid_r_proto='0'
+ctime_r_proto='0'
+d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+d_PRIEUldbl='undef'
+d_PRIFUldbl='undef'
+d_PRIGUldbl='undef'
+d_PRIXU64='undef'
+d_PRId64='undef'
+d_PRIeldbl='undef'
+d_PRIfldbl='undef'
+d_PRIgldbl='undef'
+d_PRIi64='undef'
+d_PRIo64='undef'
+d_PRIu64='undef'
+d_PRIx64='undef'
+d_SCNfldbl='undef'
+d__fwalk='undef'
+d_access='define'
+d_accessx='undef'
+d_aintl='undef'
+d_alarm='define'
+d_archlib='define'
+d_asctime64='undef'
+d_asctime_r='undef'
+d_atolf='undef'
+d_atoll='undef'
+d_attribute_deprecated='undef'
+d_attribute_format='undef'
+d_attribute_malloc='undef'
+d_attribute_nonnull='undef'
+d_attribute_noreturn='undef'
+d_attribute_pure='undef'
+d_attribute_unused='undef'
+d_attribute_warn_unused_result='undef'
+d_bcmp='undef'
+d_bcopy='undef'
+d_bsd='define'
+d_bsdgetpgrp='undef'
+d_bsdsetpgrp='undef'
+d_builtin_choose_expr='undef'
+d_builtin_expect='undef'
+d_bzero='undef'
+d_c99_variadic_macros='undef'
+d_casti32='define'
+d_castneg='define'
+d_charvspr='undef'
+d_chown='undef'
+d_chroot='undef'
+d_chsize='define'
+d_class='undef'
+d_clearenv='undef'
+d_closedir='define'
+d_cmsghdr_s='undef'
+d_const='define'
+d_copysignl='undef'
+d_cplusplus='undef'
+d_crypt='define'
+d_crypt_r='undef'
+d_csh='undef'
+d_ctermid='undef'
+d_ctermid_r='undef'
+d_ctime64='undef'
+d_ctime_r='undef'
+d_cuserid='undef'
+d_dbl_dig='define'
+d_dbminitproto='undef'
+d_difftime64='undef'
+d_difftime='define'
+d_dir_dd_fd='undef'
+d_dirfd='undef'
+d_dirnamlen='define'
+d_dlerror='define'
+d_dlopen='define'
+d_dlsymun='undef'
+d_dosuid='undef'
+d_drand48_r='undef'
+d_drand48proto='undef'
+d_dup2='define'
+d_eaccess='undef'
+d_endgrent='undef'
+d_endgrent_r='undef'
+d_endhent='undef'
+d_endhostent_r='undef'
+d_endnent='undef'
+d_endnetent_r='undef'
+d_endpent='undef'
+d_endprotoent_r='undef'
+d_endpwent='undef'
+d_endpwent_r='undef'
+d_endsent='undef'
+d_endservent_r='undef'
+d_eofnblk='define'
+d_eunice='undef'
+d_faststdio='define'
+d_fchdir='undef'
+d_fchmod='undef'
+d_fchown='undef'
+d_fcntl='undef'
+d_fcntl_can_lock='undef'
+d_fd_macros='define'
+d_fd_set='define'
+d_fds_bits='define'
+d_fgetpos='define'
+d_finite='undef'
+d_finitel='undef'
+d_flexfnam='define'
+d_flock='define'
+d_flockproto='define'
+d_fork='undef'
+d_fp_class='undef'
+d_fpathconf='undef'
+d_fpclass='undef'
+d_fpclassify='undef'
+d_fpclassl='undef'
+d_fpos64_t='undef'
+d_frexpl='undef'
+d_fs_data_s='undef'
+d_fseeko='undef'
+d_fsetpos='define'
+d_fstatfs='undef'
+d_fstatvfs='undef'
+d_fsync='undef'
+d_ftello='undef'
+d_ftime='define'
+d_futimes='undef'
+d_gdbm_ndbm_h_uses_prototypes='undef'
+d_gdbmndbm_h_uses_prototypes='undef'
+d_getaddrinfo='undef'
+d_getcwd='define'
+d_getespwnam='undef'
+d_getfsstat='undef'
+d_getgrent='undef'
+d_getgrent_r='undef'
+d_getgrgid_r='undef'
+d_getgrnam_r='undef'
+d_getgrps='undef'
+d_gethbyaddr='define'
+d_gethbyname='define'
+d_gethent='undef'
+d_gethname='define'
+d_gethostbyaddr_r='undef'
+d_gethostbyname_r='undef'
+d_gethostent_r='undef'
+d_gethostprotos='define'
+d_getitimer='undef'
+d_getlogin='define'
+d_getlogin_r='undef'
+d_getmnt='undef'
+d_getmntent='undef'
+d_getnameinfo='undef'
+d_getnbyaddr='undef'
+d_getnbyname='undef'
+d_getnent='undef'
+d_getnetbyaddr_r='undef'
+d_getnetbyname_r='undef'
+d_getnetent_r='undef'
+d_getnetprotos='undef'
+d_getpagsz='undef'
+d_getpbyname='define'
+d_getpbynumber='define'
+d_getpent='undef'
+d_getpgid='undef'
+d_getpgrp2='undef'
+d_getpgrp='undef'
+d_getppid='undef'
+d_getprior='undef'
+d_getprotobyname_r='undef'
+d_getprotobynumber_r='undef'
+d_getprotoent_r='undef'
+d_getprotoprotos='define'
+d_getprpwnam='undef'
+d_getpwent='undef'
+d_getpwent_r='undef'
+d_getpwnam_r='undef'
+d_getpwuid_r='undef'
+d_getsbyname='define'
+d_getsbyport='define'
+d_getsent='undef'
+d_getservbyname_r='undef'
+d_getservbyport_r='undef'
+d_getservent_r='undef'
+d_getservprotos='define'
+d_getspnam='undef'
+d_getspnam_r='undef'
+d_gettimeod='define'
+d_gmtime64='undef'
+d_gmtime_r='undef'
+d_gnulibc='undef'
+d_grpasswd='undef'
+d_hasmntopt='undef'
+d_htonl='define'
+d_ilogbl='undef'
+d_inc_version_list='undef'
+d_index='undef'
+d_inetaton='undef'
+d_inetntop='undef'
+d_inetpton='undef'
+d_int64_t='undef'
+d_isascii='define'
+d_isfinite='undef'
+d_isinf='undef'
+d_isnan='define'
+d_isnanl='undef'
+d_killpg='define'
+d_lchown='undef'
+d_ldbl_dig='define'
+d_libm_lib_version='undef'
+d_link='define'
+d_localtime64='undef'
+d_localtime_r='undef'
+d_localtime_r_needs_tzset='undef'
+d_locconv='define'
+d_lockf='undef'
+d_longdbl='define'
+d_longlong='undef'
+d_lseekproto='define'
+d_lstat='undef'
+d_madvise='undef'
+d_malloc_good_size='undef'
+d_malloc_size='undef'
+d_mblen='define'
+d_mbstowcs='define'
+d_mbtowc='define'
+d_memchr='define'
+d_memcmp='define'
+d_memcpy='define'
+d_memmove='define'
+d_memset='define'
+d_mkdir='define'
+d_mkdtemp='undef'
+d_mkfifo='undef'
+d_mkstemp='undef'
+d_mkstemps='undef'
+d_mktime64='undef'
+d_mktime='define'
+d_mmap='undef'
+d_modfl='undef'
+d_modfl_pow32_bug='undef'
+d_modflproto='undef'
+d_mprotect='undef'
+d_msg='undef'
+d_msg_ctrunc='undef'
+d_msg_dontroute='undef'
+d_msg_oob='undef'
+d_msg_peek='undef'
+d_msg_proxy='undef'
+d_msgctl='undef'
+d_msgget='undef'
+d_msghdr_s='undef'
+d_msgrcv='undef'
+d_msgsnd='undef'
+d_msync='undef'
+d_munmap='undef'
+d_mymalloc='undef'
+d_ndbm='undef'
+d_ndbm_h_uses_prototypes='undef'
+d_nice='undef'
+d_nl_langinfo='undef'
+d_nv_preserves_uv='define'
+d_nv_zero_is_allbits_zero='define'
+d_off64_t='undef'
+d_old_pthread_create_joinable='undef'
+d_oldpthreads='undef'
+d_oldsock='undef'
+d_open3='undef'
+d_pathconf='undef'
+d_pause='define'
+d_perl_otherlibdirs='undef'
+d_phostname='undef'
+d_pipe='define'
+d_poll='undef'
+d_portable='define'
+d_printf_format_null='undef'
+d_procselfexe='undef'
+d_pseudofork='define'
+d_pthread_atfork='undef'
+d_pthread_attr_setscope='undef'
+d_pthread_yield='undef'
+d_pwage='undef'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwcomment='undef'
+d_pwexpire='undef'
+d_pwgecos='undef'
+d_pwpasswd='undef'
+d_pwquota='undef'
+d_qgcvt='undef'
+d_quad='define'
+d_random_r='undef'
+d_readdir64_r='undef'
+d_readdir='define'
+d_readdir_r='undef'
+d_readlink='undef'
+d_readv='undef'
+d_recvmsg='undef'
+d_rename='define'
+d_rewinddir='define'
+d_rmdir='define'
+d_safebcpy='undef'
+d_safemcpy='undef'
+d_sanemcmp='define'
+d_sbrkproto='undef'
+d_scalbnl='undef'
+d_sched_yield='undef'
+d_scm_rights='undef'
+d_seekdir='define'
+d_select='define'
+d_sem='undef'
+d_semctl='undef'
+d_semctl_semid_ds='undef'
+d_semctl_semun='undef'
+d_semget='undef'
+d_semop='undef'
+d_sendmsg='undef'
+d_setegid='undef'
+d_seteuid='undef'
+d_setgrent='undef'
+d_setgrent_r='undef'
+d_setgrps='undef'
+d_sethent='undef'
+d_sethostent_r='undef'
+d_setitimer='undef'
+d_setlinebuf='undef'
+d_setlocale='define'
+d_setlocale_r='undef'
+d_setnent='undef'
+d_setnetent_r='undef'
+d_setpent='undef'
+d_setpgid='undef'
+d_setpgrp2='undef'
+d_setpgrp='undef'
+d_setprior='undef'
+d_setproctitle='undef'
+d_setprotoent_r='undef'
+d_setpwent='undef'
+d_setpwent_r='undef'
+d_setregid='undef'
+d_setresgid='undef'
+d_setresuid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+d_setsent='undef'
+d_setservent_r='undef'
+d_setsid='undef'
+d_setvbuf='define'
+d_sfio='undef'
+d_shm='undef'
+d_shmat='undef'
+d_shmatprototype='undef'
+d_shmctl='undef'
+d_shmdt='undef'
+d_shmget='undef'
+d_sigaction='undef'
+d_signbit='undef'
+d_sigprocmask='undef'
+d_sigsetjmp='undef'
+d_sitearch='define'
+d_snprintf='define'
+d_sockatmark='undef'
+d_sockatmarkproto='undef'
+d_socket='define'
+d_socklen_t='undef'
+d_sockpair='undef'
+d_socks5_init='undef'
+d_sprintf_returns_strlen='define'
+d_sqrtl='undef'
+d_srand48_r='undef'
+d_srandom_r='undef'
+d_sresgproto='undef'
+d_sresuproto='undef'
+d_statblks='undef'
+d_statfs_f_flags='undef'
+d_statfs_s='undef'
+d_statvfs='undef'
+d_stdio_cnt_lval='define'
+d_stdio_ptr_lval='define'
+d_stdio_ptr_lval_nochange_cnt='define'
+d_stdio_ptr_lval_sets_cnt='undef'
+d_stdio_stream_array='undef'
+d_stdiobase='define'
+d_stdstdio='define'
+d_strchr='define'
+d_strcoll='define'
+d_strctcpy='define'
+d_strerrm='strerror(e)'
+d_strerror='define'
+d_strerror_r='undef'
+d_strftime='define'
+d_strlcat='undef'
+d_strlcpy='undef'
+d_strtod='define'
+d_strtol='define'
+d_strtold='undef'
+d_strtoll='undef'
+d_strtoq='undef'
+d_strtoul='define'
+d_strtoull='undef'
+d_strtouq='undef'
+d_strxfrm='define'
+d_suidsafe='undef'
+d_symlink='undef'
+d_syscall='undef'
+d_syscallproto='undef'
+d_sysconf='undef'
+d_sysernlst=''
+d_syserrlst='define'
+d_system='define'
+d_tcgetpgrp='undef'
+d_tcsetpgrp='undef'
+d_telldir='define'
+d_telldirproto='define'
+d_time='define'
+d_timegm='undef'
+d_times='define'
+d_tm_tm_gmtoff='undef'
+d_tm_tm_zone='undef'
+d_tmpnam_r='undef'
+d_truncate='undef'
+d_ttyname_r='undef'
+d_tzname='define'
+d_u32align='define'
+d_ualarm='undef'
+d_umask='define'
+d_uname='define'
+d_union_semun='define'
+d_unordered='undef'
+d_unsetenv='undef'
+d_usleep='undef'
+d_usleepproto='undef'
+d_ustat='undef'
+d_vendorarch='undef'
+d_vendorbin='undef'
+d_vendorlib='undef'
+d_vendorscript='undef'
+d_vfork='undef'
+d_void_closedir='undef'
+d_voidsig='define'
+d_voidtty=''
+d_volatile='define'
+d_vprintf='define'
+d_vsnprintf='define'
+d_wait4='undef'
+d_waitpid='define'
+d_wcstombs='define'
+d_wctomb='define'
+d_writev='undef'
+d_xenix='undef'
+date='date'
+db_hashtype='int'
+db_prefixtype='int'
+db_version_major='0'
+db_version_minor='0'
+db_version_patch='0'
+defvoidused='15'
+direntrytype='struct direct'
+dlext='dll'
+dlsrc='dl_win32.xs'
+doublesize='8'
+drand01='(rand()/(double)((unsigned)1<<RANDBITS))'
+drand48_r_proto='0'
+dtrace=''
+dynamic_ext='B Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call Hash/Util Hash/Util/FieldHash IO List/Util MIME/Base64 Math/BigInt/FastCalc Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Text/Soundex Time/HiRes Time/Piece Unicode/Normalize Win32 Win32API/File XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes mro re threads threads/shared'
+eagain='EAGAIN'
+ebcdic='undef'
+echo='echo'
+egrep='egrep'
+emacs=''
+endgrent_r_proto='0'
+endhostent_r_proto='0'
+endnetent_r_proto='0'
+endprotoent_r_proto='0'
+endpwent_r_proto='0'
+endservent_r_proto='0'
+eunicefix=':'
+exe_ext='.exe'
+expr='expr'
+extensions='Archive/Extract Archive/Tar Attribute/Handlers AutoLoader B B/Debug B/Deparse B/Lint CGI CPAN CPANPLUS CPANPLUS/Dist/Build Class/ISA Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Devel/SelfStubber Digest Digest/MD5 Digest/SHA Encode Errno ExtUtils/CBuilder ExtUtils/Command ExtUtils/Constant ExtUtils/Install ExtUtils/MakeMaker ExtUtils/Manifest ExtUtils/ParseXS Fcntl File/Fetch File/Glob File/Path File/Temp FileCache Filter/Simple Filter/Util/Call Getopt/Long Hash/Util Hash/Util/FieldHash I18N/LangTags IO IO/Compress IO/Zlib IPC/Cmd IPC/Open2 IPC/Open3 List/Util Locale/Codes Locale/Maketext Locale/Maketext/Simple Log/Message Log/Message/Simple MIME/Base64 Math/BigInt Math/BigInt/FastCalc Math/BigRat Math/Complex Memoize Module/Build Module/CoreList Module/Load Module/Load/Conditional Module/Loaded Module/Pluggable NEXT Net/Ping Object/Accessor Opcode POSIX Package/Constants Params/Check Parse/CPAN/Meta PerlIO/encoding PerlIO/scalar PerlIO/via PerlIO/via/QuotedPrint Pod/Escapes Pod/LaTeX Pod/Parser Pod/Perldoc Pod/Plainer Pod/Simple SDBM_File Safe SelfLoader Shell Socket Storable Switch Sys/Hostname Term/ANSIColor Term/Cap Term/UI Test Test/Harness Test/Simple Text/Balanced Text/ParseWords Text/Soundex Text/Tabs Thread/Queue Thread/Semaphore Tie/File Tie/Memoize Tie/RefHash Time/HiRes Time/Local Time/Piece Unicode/Collate Unicode/Normalize Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap XSLoader attributes autodie autouse base bignum constant encoding/warnings if lib libnet mro parent podlators re threads threads/shared'
+extern_C='extern'
+extras=''
+fflushNULL='define'
+fflushall='undef'
+find='find'
+firstmakefile='makefile'
+flex=''
+fpossize='8'
+fpostype='fpos_t'
+freetype='void'
+from=':'
+full_ar=''
+full_csh=''
+full_sed=''
+gccansipedantic=''
+gccosandvers=''
+gccversion='4.5.0'
+getgrent_r_proto='0'
+getgrgid_r_proto='0'
+getgrnam_r_proto='0'
+gethostbyaddr_r_proto='0'
+gethostbyname_r_proto='0'
+gethostent_r_proto='0'
+getlogin_r_proto='0'
+getnetbyaddr_r_proto='0'
+getnetbyname_r_proto='0'
+getnetent_r_proto='0'
+getprotobyname_r_proto='0'
+getprotobynumber_r_proto='0'
+getprotoent_r_proto='0'
+getpwent_r_proto='0'
+getpwnam_r_proto='0'
+getpwuid_r_proto='0'
+getservbyname_r_proto='0'
+getservbyport_r_proto='0'
+getservent_r_proto='0'
+getspnam_r_proto='0'
+gidformat='"ld"'
+gidsign='-1'
+gidsize='4'
+gidtype='gid_t'
+glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib '
+gmake='gmake'
+gmtime_r_proto='0'
+gnulibc_version=''
+grep='grep'
+groupcat=''
+groupstype='gid_t'
+gzip='gzip'
+h_fcntl='false'
+h_sysfile='true'
+hint='recommended'
+hostcat='ypcat hosts'
+html1dir=' '
+html1direxp=''
+html3dir=' '
+html3direxp=''
+i16size='2'
+i16type='short'
+i32size='4'
+i32type='long'
+i64size='8'
+i64type='long long'
+i8size='1'
+i8type='char'
+i_arpainet='define'
+i_assert='define'
+i_bsdioctl=''
+i_crypt='undef'
+i_db='undef'
+i_dbm='undef'
+i_dirent='define'
+i_dld='undef'
+i_dlfcn='define'
+i_fcntl='define'
+i_float='define'
+i_fp='undef'
+i_fp_class='undef'
+i_gdbm='undef'
+i_gdbm_ndbm='undef'
+i_gdbmndbm='undef'
+i_grp='undef'
+i_ieeefp='undef'
+i_inttypes='undef'
+i_langinfo='undef'
+i_libutil='undef'
+i_limits='define'
+i_locale='define'
+i_machcthr='undef'
+i_malloc='define'
+i_mallocmalloc='undef'
+i_math='define'
+i_memory='undef'
+i_mntent='undef'
+i_ndbm='undef'
+i_netdb='undef'
+i_neterrno='undef'
+i_netinettcp='undef'
+i_niin='undef'
+i_poll='undef'
+i_prot='undef'
+i_pthread='undef'
+i_pwd='undef'
+i_rpcsvcdbm='define'
+i_sfio='undef'
+i_sgtty='undef'
+i_shadow='undef'
+i_socks='undef'
+i_stdarg='define'
+i_stddef='define'
+i_stdlib='define'
+i_string='define'
+i_sunmath='undef'
+i_sysaccess='undef'
+i_sysdir='undef'
+i_sysfile='undef'
+i_sysfilio='define'
+i_sysin='undef'
+i_sysioctl='undef'
+i_syslog='undef'
+i_sysmman='undef'
+i_sysmode='undef'
+i_sysmount='undef'
+i_sysndir='undef'
+i_sysparam='undef'
+i_syspoll='undef'
+i_sysresrc='undef'
+i_syssecrt='undef'
+i_sysselct='undef'
+i_syssockio='undef'
+i_sysstat='define'
+i_sysstatfs='undef'
+i_sysstatvfs='undef'
+i_systime='undef'
+i_systimek='undef'
+i_systimes='undef'
+i_systypes='define'
+i_sysuio='undef'
+i_sysun='undef'
+i_sysutsname='undef'
+i_sysvfs='undef'
+i_syswait='undef'
+i_termio='undef'
+i_termios='undef'
+i_time='define'
+i_unistd='undef'
+i_ustat='undef'
+i_utime='define'
+i_values='undef'
+i_varargs='undef'
+i_varhdr='varargs.h'
+i_vfork='undef'
+ignore_versioned_solibs=''
+inc_version_list=''
+inc_version_list_init='0'
+incpath='X:\mingw32\include'
+inews=''
+initialinstalllocation=''
+installarchlib='c:\perl\lib'
+installbin='c:\perl\bin'
+installhtml1dir=''
+installhtml3dir=''
+installhtmldir='c:\perl\html'
+installhtmlhelpdir='c:\perl\htmlhelp'
+installman1dir='c:\perl\man\man1'
+installman3dir='c:\perl\man\man3'
+installprefix='c:\perl'
+installprefixexp='c:\perl'
+installprivlib='c:\perl\lib'
+installscript='c:\perl\bin'
+installsitearch='c:\perl\site\lib'
+installsitebin='c:\perl\bin'
+installsitehtml1dir=''
+installsitehtml3dir=''
+installsitelib='c:\perl\site\lib'
+installsiteman1dir=''
+installsiteman3dir=''
+installsitescript=''
+installstyle='lib'
+installusrbinperl='undef'
+installvendorarch=''
+installvendorbin=''
+installvendorhtml1dir=''
+installvendorhtml3dir=''
+installvendorlib=''
+installvendorman1dir=''
+installvendorman3dir=''
+installvendorscript=''
+intsize='4'
+issymlink=''
+ivdformat='"ld"'
+ivsize='4'
+ivtype='long'
+known_extensions='B Compress/Raw/Bzip2 Compress/Raw/Zlib Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Digest/SHA Encode Fcntl File/Glob Filter/Util/Call GDBM_File Hash/Util Hash/Util/FieldHash I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 Math/BigInt/FastCalc NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Text/Soundex Time/HiRes Time/Piece Unicode/Normalize VMS/DCLsym VMS/Stdio Win32 Win32API/File Win32CORE XS/APItest XS/APItest/KeywordRPN XS/Typemap attributes mro re threads threads/shared'
+ksh=''
+ld='g++'
+lddlflags='-mdll -s -L"c:\perl\lib\CORE" -L"X:\mingw32\lib"'
+ldflags='-s -L"c:\perl\lib\CORE" -L"X:\mingw32\lib"'
+ldflags_uselargefiles=''
+ldlibpthname=''
+less='less'
+lib_ext='.a'
+libc=''
+libperl='libperl512.a'
+libpth='X:\mingw32\lib'
+libs='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32'
+libsdirs=''
+libsfiles=''
+libsfound=''
+libspath=''
+libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+libswanted_uselargefiles='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+line='line'
+lint=''
+lkflags=''
+ln=''
+lns='copy'
+localtime_r_proto='0'
+locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+longdblsize='12'
+longlongsize='8'
+longsize='4'
+lp=''
+lpr=''
+ls='dir'
+lseeksize='8'
+lseektype='long long'
+mad='undef'
+madlyh=''
+madlyobj=''
+madlysrc=''
+mail=''
+mailx=''
+make='dmake'
+make_set_make='#'
+mallocobj='malloc.o'
+mallocsrc='malloc.c'
+malloctype='void *'
+man1dir='c:\perl\man\man1'
+man1direxp='c:\perl\man\man1'
+man1ext='1'
+man3dir='c:\perl\man\man3'
+man3direxp='c:\perl\man\man3'
+man3ext='3'
+mips_type=''
+mistrustnm=''
+mkdir='mkdir'
+mmaptype='void *'
+modetype='mode_t'
+more='more /e'
+multiarch='undef'
+mv=''
+myarchname='MSWin32'
+mydomain=''
+myhostname=''
+myuname=''
+n='-n'
+need_va_copy='undef'
+netdb_hlen_type='int'
+netdb_host_type='char *'
+netdb_name_type='char *'
+netdb_net_type='long'
+nm='nm'
+nm_opt=''
+nm_so_opt=''
+nonxs_ext='Archive/Extract Archive/Tar Attribute/Handlers AutoLoader B/Debug B/Deparse B/Lint CGI CPAN CPANPLUS CPANPLUS/Dist/Build Class/ISA Devel/SelfStubber Digest Errno ExtUtils/CBuilder ExtUtils/Command ExtUtils/Constant ExtUtils/Install ExtUtils/MakeMaker ExtUtils/Manifest ExtUtils/ParseXS File/Fetch File/Path File/Temp FileCache Filter/Simple Getopt/Long I18N/LangTags IO/Compress IO/Zlib IPC/Cmd IPC/Open2 IPC/Open3 Locale/Codes Locale/Maketext Locale/Maketext/Simple Log/Message Log/Message/Simple Math/BigInt Math/BigRat Math/Complex Memoize Module/Build Module/CoreList Module/Load Module/Load/Conditional Module/Loaded Module/Pluggable NEXT Net/Ping Object/Accessor Package/Constants Params/Check Parse/CPAN/Meta PerlIO/via/QuotedPrint Pod/Escapes Pod/LaTeX Pod/Parser Pod/Perldoc Pod/Plainer Pod/Simple Safe SelfLoader Shell Switch Term/ANSIColor Term/Cap Term/UI Test Test/Harness Test/Simple Text/Balanced Text/ParseWords Text/Tabs Thread/Queue Thread/Semaphore Tie/File Tie/Memoize Tie/RefHash Time/Local Unicode/Collate XSLoader autodie autouse base bignum constant encoding/warnings if lib libnet parent podlators'
+nroff=''
+nvEUformat='"E"'
+nvFUformat='"F"'
+nvGUformat='"G"'
+nv_overflows_integers_at='256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0'
+nv_preserves_uv_bits='32'
+nveformat='"e"'
+nvfformat='"f"'
+nvgformat='"g"'
+nvsize='8'
+nvtype='double'
+o_nonblock='O_NONBLOCK'
+obj_ext='.o'
+old_pthread_create_joinable=''
+optimize='-s -O2'
+orderlib='false'
+osname='MSWin32'
+osvers='5.1'
+otherlibdirs=''
+package='perl5'
+pager='more /e'
+passcat=''
+patchlevel='12'
+path_sep=';'
+perl5=''
+perl='perl'
+perl_patchlevel=''
+perladmin=''
+perllibs='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32'
+perlpath='c:\perl\bin\perl.exe'
+pg=''
+phostname='hostname'
+pidtype='int'
+plibpth=''
+pmake=''
+pr=''
+prefix='c:\perl'
+prefixexp='c:\perl'
+privlib='c:\perl\lib'
+privlibexp='c:\perl\lib'
+procselfexe=''
+prototype='define'
+ptrsize='4'
+quadkind='3'
+quadtype='long long'
+randbits='15'
+randfunc='rand'
+random_r_proto='0'
+randseedtype='unsigned'
+ranlib='rem'
+rd_nodata='-1'
+readdir64_r_proto='0'
+readdir_r_proto='0'
+revision='5'
+rm='del'
+rm_try=''
+rmail=''
+run=''
+runnm='true'
+sGMTIME_max="2147483647"
+sGMTIME_min="0"
+sLOCALTIME_max="2147483647"
+sLOCALTIME_min="0"
+sPRIEUldbl='"E"'
+sPRIFUldbl='"F"'
+sPRIGUldbl='"G"'
+sPRIXU64='"lX"'
+sPRId64='"ld"'
+sPRIeldbl='"e"'
+sPRIfldbl='"f"'
+sPRIgldbl='"g"'
+sPRIi64='"li"'
+sPRIo64='"lo"'
+sPRIu64='"lu"'
+sPRIx64='"lx"'
+sSCNfldbl='"f"'
+sched_yield=''
+scriptdir='c:\perl\bin'
+scriptdirexp='c:\perl\bin'
+sed='sed'
+seedfunc='srand'
+selectminbits='32'
+selecttype='Perl_fd_set *'
+sendmail='blat'
+setgrent_r_proto='0'
+sethostent_r_proto='0'
+setlocale_r_proto='0'
+setnetent_r_proto='0'
+setprotoent_r_proto='0'
+setpwent_r_proto='0'
+setservent_r_proto='0'
+sh='cmd /x /c'
+shar=''
+sharpbang='#!'
+shmattype='void *'
+shortsize='2'
+shrpenv=''
+shsharp='true'
+sig_count='26'
+sig_name='ZERO HUP INT QUIT ILL NUM05 NUM06 NUM07 FPE KILL NUM10 SEGV NUM12 PIPE ALRM TERM NUM16 NUM17 NUM18 NUM19 CHLD BREAK ABRT STOP NUM24 CONT CLD'
+sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0'
+sig_num='0 1 2 21 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20'
+sig_num_init='0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0'
+sig_size='27'
+signal_t='void'
+sitearch='c:\perl\site\lib'
+sitearchexp='c:\perl\site\lib'
+sitebin='c:\perl\site\bin'
+sitebinexp='c:\perl\site\bin'
+sitehtml1dir=''
+sitehtml1direxp=''
+sitehtml3dir=''
+sitehtml3direxp=''
+sitelib='c:\perl\site\lib'
+sitelib_stem=''
+sitelibexp='c:\perl\site\lib'
+siteman1dir=''
+siteman1direxp=''
+siteman3dir=''
+siteman3direxp=''
+siteprefix='c:\perl\site'
+siteprefixexp='c:\perl\site'
+sitescript=''
+sitescriptexp=''
+sizesize='4'
+sizetype='size_t'
+sleep=''
+smail=''
+so='dll'
+sockethdr=''
+socketlib=''
+socksizetype='int'
+sort='sort'
+spackage='Perl5'
+spitshell=''
+srand48_r_proto='0'
+srandom_r_proto='0'
+src=''
+ssizetype='int'
+startperl='#!perl'
+startsh='#!/bin/sh'
+static_ext='Win32CORE'
+stdchar='char'
+stdio_base='((fp)->_base)'
+stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
+stdio_cnt='((fp)->_cnt)'
+stdio_filbuf=''
+stdio_ptr='((fp)->_ptr)'
+stdio_stream_array=''
+strerror_r_proto='0'
+strings='/usr/include/string.h'
+submit=''
+subversion=''
+sysman='/usr/man/man1'
+tail=''
+tar=''
+targetarch=''
+tbl=''
+tee=''
+test=''
+timeincl='/usr/include/sys/time.h '
+timetype='time_t'
+tmpnam_r_proto='0'
+to=':'
+touch='touch'
+tr=''
+trnl='\012'
+troff=''
+ttyname_r_proto='0'
+u16size='2'
+u16type='unsigned short'
+u32size='4'
+u32type='unsigned long'
+u64size='8'
+u64type='unsigned long long'
+u8size='1'
+u8type='unsigned char'
+uidformat='"ld"'
+uidsign='-1'
+uidsize='4'
+uidtype='uid_t'
+uname='uname'
+uniq='uniq'
+uquadtype='unsigned long long'
+use5005threads='undef'
+use64bitall='undef'
+use64bitint='undef'
+usecrosscompile='undef'
+usedevel='undef'
+usedl='define'
+usedtrace='undef'
+usefaststdio='undef'
+useithreads='define'
+uselargefiles='define'
+uselongdouble='undef'
+usemallocwrap='define'
+usemorebits='undef'
+usemultiplicity='define'
+usemymalloc='n'
+usenm='false'
+useopcode='true'
+useperlio='define'
+useposix='true'
+usereentrant='undef'
+userelocatableinc='undef'
+usesfio='false'
+useshrplib='true'
+usesitecustomize='undef'
+usesocks='undef'
+usethreads='define'
+usevendorprefix='undef'
+usevfork='false'
+usrinc='/usr/include'
+uuname=''
+uvXUformat='"lX"'
+uvoformat='"lo"'
+uvsize='4'
+uvtype='unsigned long'
+uvuformat='"lu"'
+uvxformat='"lx"'
+vaproto='undef'
+vendorarch=''
+vendorarchexp=''
+vendorbin=''
+vendorbinexp=''
+vendorhtml1dir=' '
+vendorhtml1direxp=''
+vendorhtml3dir=' '
+vendorhtml3direxp=''
+vendorlib=''
+vendorlib_stem=''
+vendorlibexp=''
+vendorman1dir=' '
+vendorman1direxp=''
+vendorman3dir=' '
+vendorman3direxp=''
+vendorprefix=''
+vendorprefixexp=''
+vendorscript=''
+vendorscriptexp=''
+version='5.12.3'
+version_patchlevel_string='version 12 subversion 3'
+versiononly='undef'
+vi=''
+voidflags='15'
+xlibpth='/usr/lib/386 /lib/386'
+yacc='yacc'
+yaccflags=''
+zcat=''
+zip='zip'
+!END!
+
+my $i = 0;
+foreach my $c (4,3,2) { $i |= ord($c); $i <<= 8 }
+$i |= ord(1);
+our $byteorder = join('', unpack('aaaa', pack('L!', $i)));
+s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
+
+my $config_sh_len = length $_;
+
+our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL';
+ccflags_nolargefiles=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX'
+ldflags_nolargefiles='-s -L"c:\perl\lib\CORE" -L"X:\mingw32\lib"'
+libs_nolargefiles='-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32'
+libswanted_nolargefiles=''
+EOVIRTUAL
+eval {
+ # do not have hairy conniptions if this isnt available
+ require 'Config_git.pl';
+ $Config_SH_expanded .= $Config::Git_Data;
+ 1;
+} or warn "Warning: failed to load Config_git.pl, something strange about this perl...\n";
+
+# Search for it in the big string
+sub fetch_string {
+ my($self, $key) = @_;
+
+ my $quote_type = "'";
+ my $marker = "$key=";
+
+ # Check for the common case, ' delimited
+ my $start = index($Config_SH_expanded, "\n$marker$quote_type");
+ # If that failed, check for " delimited
+ if ($start == -1) {
+ $quote_type = '"';
+ $start = index($Config_SH_expanded, "\n$marker$quote_type");
+ }
+ # Start can never be -1 now, as we've rigged the long string we're
+ # searching with an initial dummy newline.
+ return undef if $start == -1;
+
+ $start += length($key) + 3;
+
+ my $value = substr($Config_SH_expanded, $start,
+ index($Config_SH_expanded, "$quote_type\n", $start)
+ - $start);
+
+ # If we had a double-quote, we'd better eval it so escape
+ # sequences and such can be interpolated. Since the incoming
+ # value is supposed to follow shell rules and not perl rules,
+ # we escape any perl variable markers
+ if ($quote_type eq '"') {
+ $value =~ s/\$/\\\$/g;
+ $value =~ s/\@/\\\@/g;
+ eval "\$value = \"$value\"";
+ }
+ # So we can say "if $Config{'foo'}".
+ $value = undef if $value eq 'undef';
+ $self->{$key} = $value; # cache it
+}
+
+my $prevpos = 0;
+
+sub FIRSTKEY {
+ $prevpos = 0;
+ substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
+}
+
+sub NEXTKEY {
+ # Find out how the current key's quoted so we can skip to its end.
+ my $quote = substr($Config_SH_expanded,
+ index($Config_SH_expanded, "=", $prevpos)+1, 1);
+ my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
+ my $len = index($Config_SH_expanded, "=", $pos) - $pos;
+ $prevpos = $pos;
+ $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
+}
+
+sub EXISTS {
+ return 1 if exists($_[0]->{$_[1]});
+
+ return(index($Config_SH_expanded, "\n$_[1]='") != -1
+ or index($Config_SH_expanded, "\n$_[1]=\"") != -1
+ );
+}
+
+sub STORE { die "\%Config::Config is read-only\n" }
+*DELETE = \&STORE;
+*CLEAR = \&STORE;
+
+
+sub config_sh {
+ substr $Config_SH_expanded, 1, $config_sh_len;
+}
+
+sub config_re {
+ my $re = shift;
+ return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
+ $Config_SH_expanded;
+}
+
+sub config_vars {
+ # implements -V:cfgvar option (see perlrun -V:)
+ foreach (@_) {
+ # find optional leading, trailing colons; and query-spec
+ my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft,
+ # map colon-flags to print decorations
+ my $prfx = $notag ? '': "$qry="; # tag-prefix for print
+ my $lnend = $lncont ? ' ' : ";\n"; # line ending for print
+
+ # all config-vars are by definition \w only, any \W means regex
+ if ($qry =~ /\W/) {
+ my @matches = config_re($qry);
+ print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag;
+ print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag;
+ } else {
+ my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
+ : 'UNKNOWN';
+ $v = 'undef' unless defined $v;
+ print "${prfx}'${v}'$lnend";
+ }
+ }
+}
+
+# Called by the real AUTOLOAD
+sub launcher {
+ undef &AUTOLOAD;
+ goto \&$Config::AUTOLOAD;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Cwd.pm b/Master/tlpkg/tlperl/lib/Cwd.pm
new file mode 100644
index 00000000000..a5e2cda932b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Cwd.pm
@@ -0,0 +1,824 @@
+package Cwd;
+
+=head1 NAME
+
+Cwd - get pathname of current working directory
+
+=head1 SYNOPSIS
+
+ use Cwd;
+ my $dir = getcwd;
+
+ use Cwd 'abs_path';
+ my $abs_path = abs_path($file);
+
+=head1 DESCRIPTION
+
+This module provides functions for determining the pathname of the
+current working directory. It is recommended that getcwd (or another
+*cwd() function) be used in I<all> code to ensure portability.
+
+By default, it exports the functions cwd(), getcwd(), fastcwd(), and
+fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
+
+
+=head2 getcwd and friends
+
+Each of these functions are called without arguments and return the
+absolute path of the current working directory.
+
+=over 4
+
+=item getcwd
+
+ my $cwd = getcwd();
+
+Returns the current working directory.
+
+Exposes the POSIX function getcwd(3) or re-implements it if it's not
+available.
+
+=item cwd
+
+ my $cwd = cwd();
+
+The cwd() is the most natural form for the current architecture. For
+most systems it is identical to `pwd` (but without the trailing line
+terminator).
+
+=item fastcwd
+
+ my $cwd = fastcwd();
+
+A more dangerous version of getcwd(), but potentially faster.
+
+It might conceivably chdir() you out of a directory that it can't
+chdir() you back into. If fastcwd encounters a problem it will return
+undef but will probably leave you in a different directory. For a
+measure of extra security, if everything appears to have worked, the
+fastcwd() function will check that it leaves you in the same directory
+that it started in. If it has changed it will C<die> with the message
+"Unstable directory path, current directory changed
+unexpectedly". That should never happen.
+
+=item fastgetcwd
+
+ my $cwd = fastgetcwd();
+
+The fastgetcwd() function is provided as a synonym for cwd().
+
+=item getdcwd
+
+ my $cwd = getdcwd();
+ my $cwd = getdcwd('C:');
+
+The getdcwd() function is also provided on Win32 to get the current working
+directory on the specified drive, since Windows maintains a separate current
+working directory for each drive. If no drive is specified then the current
+drive is assumed.
+
+This function simply calls the Microsoft C library _getdcwd() function.
+
+=back
+
+
+=head2 abs_path and friends
+
+These functions are exported only on request. They each take a single
+argument and return the absolute pathname for it. If no argument is
+given they'll use the current working directory.
+
+=over 4
+
+=item abs_path
+
+ my $abs_path = abs_path($file);
+
+Uses the same algorithm as getcwd(). Symbolic links and relative-path
+components ("." and "..") are resolved to return the canonical
+pathname, just like realpath(3).
+
+=item realpath
+
+ my $abs_path = realpath($file);
+
+A synonym for abs_path().
+
+=item fast_abs_path
+
+ my $abs_path = fast_abs_path($file);
+
+A more dangerous, but potentially faster version of abs_path.
+
+=back
+
+=head2 $ENV{PWD}
+
+If you ask to override your chdir() built-in function,
+
+ use Cwd qw(chdir);
+
+then your PWD environment variable will be kept up to date. Note that
+it will only be kept up to date if all packages which use chdir import
+it from Cwd.
+
+
+=head1 NOTES
+
+=over 4
+
+=item *
+
+Since the path seperators are different on some operating systems ('/'
+on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
+modules wherever portability is a concern.
+
+=item *
+
+Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
+functions are all aliases for the C<cwd()> function, which, on Mac OS,
+calls `pwd`. Likewise, the C<abs_path()> function is an alias for
+C<fast_abs_path()>.
+
+=back
+
+=head1 AUTHOR
+
+Originally by the perl5-porters.
+
+Maintained by Ken Williams <KWILLIAMS@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+Portions of the C code in this library are copyright (c) 1994 by the
+Regents of the University of California. All rights reserved. The
+license on this code is compatible with the licensing of the rest of
+the distribution - please see the source code in F<Cwd.xs> for the
+details.
+
+=head1 SEE ALSO
+
+L<File::chdir>
+
+=cut
+
+use strict;
+use Exporter;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
+
+$VERSION = '3.31';
+my $xs_version = $VERSION;
+$VERSION = eval $VERSION;
+
+@ISA = qw/ Exporter /;
+@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
+@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+
+# sys_cwd may keep the builtin command
+
+# All the functionality of this module may provided by builtins,
+# there is no sense to process the rest of the file.
+# The best choice may be to have this in BEGIN, but how to return from BEGIN?
+
+if ($^O eq 'os2') {
+ local $^W = 0;
+
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+
+ *fast_abs_path = \&sys_abspath if defined &sys_abspath;
+ *abs_path = \&fast_abs_path;
+ *realpath = \&fast_abs_path;
+ *fast_realpath = \&fast_abs_path;
+
+ return 1;
+}
+
+# Need to look up the feature settings on VMS. The preferred way is to use the
+# VMS::Feature module, but that may not be available to dual life modules.
+
+my $use_vms_feature;
+BEGIN {
+ if ($^O eq 'VMS') {
+ if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ $use_vms_feature = 1;
+ }
+ }
+}
+
+# Need to look up the UNIX report mode. This may become a dynamic mode
+# in the future.
+sub _vms_unix_rpt {
+ my $unix_rpt;
+ if ($use_vms_feature) {
+ $unix_rpt = VMS::Feature::current("filename_unix_report");
+ } else {
+ my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+ $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
+ }
+ return $unix_rpt;
+}
+
+# Need to look up the EFS character set mode. This may become a dynamic
+# mode in the future.
+sub _vms_efs {
+ my $efs;
+ if ($use_vms_feature) {
+ $efs = VMS::Feature::current("efs_charset");
+ } else {
+ my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
+ $efs = $env_efs =~ /^[ET1]/i;
+ }
+ return $efs;
+}
+
+
+# If loading the XS stuff doesn't work, we can fall back to pure perl
+eval {
+ if ( $] >= 5.006 ) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $xs_version);
+ } else {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ __PACKAGE__->bootstrap( $xs_version );
+ }
+};
+
+# Must be after the DynaLoader stuff:
+$VERSION = eval $VERSION;
+
+# Big nasty table of function aliases
+my %METHOD_MAP =
+ (
+ VMS =>
+ {
+ cwd => '_vms_cwd',
+ getcwd => '_vms_cwd',
+ fastcwd => '_vms_cwd',
+ fastgetcwd => '_vms_cwd',
+ abs_path => '_vms_abs_path',
+ fast_abs_path => '_vms_abs_path',
+ },
+
+ MSWin32 =>
+ {
+ # We assume that &_NT_cwd is defined as an XSUB or in the core.
+ cwd => '_NT_cwd',
+ getcwd => '_NT_cwd',
+ fastcwd => '_NT_cwd',
+ fastgetcwd => '_NT_cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ dos =>
+ {
+ cwd => '_dos_cwd',
+ getcwd => '_dos_cwd',
+ fastgetcwd => '_dos_cwd',
+ fastcwd => '_dos_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ # QNX4. QNX6 has a $os of 'nto'.
+ qnx =>
+ {
+ cwd => '_qnx_cwd',
+ getcwd => '_qnx_cwd',
+ fastgetcwd => '_qnx_cwd',
+ fastcwd => '_qnx_cwd',
+ abs_path => '_qnx_abs_path',
+ fast_abs_path => '_qnx_abs_path',
+ },
+
+ cygwin =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ realpath => 'fast_abs_path',
+ },
+
+ epoc =>
+ {
+ cwd => '_epoc_cwd',
+ getcwd => '_epoc_cwd',
+ fastgetcwd => '_epoc_cwd',
+ fastcwd => '_epoc_cwd',
+ abs_path => 'fast_abs_path',
+ },
+
+ MacOS =>
+ {
+ getcwd => 'cwd',
+ fastgetcwd => 'cwd',
+ fastcwd => 'cwd',
+ abs_path => 'fast_abs_path',
+ },
+ );
+
+$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
+
+
+# Find the pwd command in the expected locations. We assume these
+# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
+# so everything works under taint mode.
+my $pwd_cmd;
+foreach my $try ('/bin/pwd',
+ '/usr/bin/pwd',
+ '/QOpenSys/bin/pwd', # OS/400 PASE.
+ ) {
+
+ if( -x $try ) {
+ $pwd_cmd = $try;
+ last;
+ }
+}
+my $found_pwd_cmd = defined($pwd_cmd);
+unless ($pwd_cmd) {
+ # Isn't this wrong? _backtick_pwd() will fail if somenone has
+ # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
+ # See [perl #16774]. --jhi
+ $pwd_cmd = 'pwd';
+}
+
+# Lazy-load Carp
+sub _carp { require Carp; Carp::carp(@_) }
+sub _croak { require Carp; Carp::croak(@_) }
+
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
+ # Localize %ENV entries in a way that won't create new hash keys
+ my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
+ local @ENV{@localize};
+
+ my $cwd = `$pwd_cmd`;
+ # Belt-and-suspenders in case someone said "undef $/".
+ local $/ = "\n";
+ # `pwd` may fail e.g. if the disk is full
+ chomp($cwd) if defined $cwd;
+ $cwd;
+}
+
+# Since some ports may predefine cwd internally (e.g., NT)
+# we take care not to override an existing definition for cwd().
+
+unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
+ # The pwd command is not available in some chroot(2)'ed environments
+ my $sep = $Config::Config{path_sep} || ':';
+ my $os = $^O; # Protect $^O from tainting
+
+
+ # Try again to find a pwd, this time searching the whole PATH.
+ if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
+ my @candidates = split($sep, $ENV{PATH});
+ while (!$found_pwd_cmd and @candidates) {
+ my $candidate = shift @candidates;
+ $found_pwd_cmd = 1 if -x "$candidate/pwd";
+ }
+ }
+
+ # MacOS has some special magic to make `pwd` work.
+ if( $os eq 'MacOS' || $found_pwd_cmd )
+ {
+ *cwd = \&_backtick_pwd;
+ }
+ else {
+ *cwd = \&getcwd;
+ }
+}
+
+if ($^O eq 'cygwin') {
+ # We need to make sure cwd() is called with no args, because it's
+ # got an arg-less prototype and will die if args are present.
+ local $^W = 0;
+ my $orig_cwd = \&cwd;
+ *cwd = sub { &$orig_cwd() }
+}
+
+
+# set a reasonable (and very safe) default for fastgetcwd, in case it
+# isn't redefined later (20001212 rspier)
+*fastgetcwd = \&cwd;
+
+# A non-XS version of getcwd() - also used to bootstrap the perl build
+# process, when miniperl is running and no XS loading happens.
+sub _perl_getcwd
+{
+ abs_path('.');
+}
+
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd_ {
+ my($odev, $oino, $cdev, $cino, $tdev, $tino);
+ my(@path, $path);
+ local(*DIR);
+
+ my($orig_cdev, $orig_cino) = stat('.');
+ ($cdev, $cino) = ($orig_cdev, $orig_cino);
+ for (;;) {
+ my $direntry;
+ ($odev, $oino) = ($cdev, $cino);
+ CORE::chdir('..') || return undef;
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.') || return undef;
+ for (;;) {
+ $direntry = readdir(DIR);
+ last unless defined $direntry;
+ next if $direntry eq '.';
+ next if $direntry eq '..';
+
+ ($tdev, $tino) = lstat($direntry);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ return undef unless defined $direntry; # should never happen
+ unshift(@path, $direntry);
+ }
+ $path = '/' . join('/', @path);
+ if ($^O eq 'apollo') { $path = "/".$path; }
+ # At this point $path may be tainted (if tainting) and chdir would fail.
+ # Untaint it then check that we landed where we started.
+ $path =~ /^(.*)\z/s # untaint
+ && CORE::chdir($1) or return undef;
+ ($cdev, $cino) = stat('.');
+ die "Unstable directory path, current directory changed unexpectedly"
+ if $cdev != $orig_cdev || $cino != $orig_cino;
+ $path;
+}
+if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
+
+
+# Keeps track of current working directory in PWD environment var
+# Usage:
+# use Cwd 'chdir';
+# chdir $newdir;
+
+my $chdir_init = 0;
+
+sub chdir_init {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
+ my($dd,$di) = stat('.');
+ my($pd,$pi) = stat($ENV{'PWD'});
+ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
+ $ENV{'PWD'} = cwd();
+ }
+ }
+ else {
+ my $wd = cwd();
+ $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
+ $ENV{'PWD'} = $wd;
+ }
+ # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
+ if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
+ my($pd,$pi) = stat($2);
+ my($dd,$di) = stat($1);
+ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+ $chdir_init = 1;
+}
+
+sub chdir {
+ my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
+ $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
+ chdir_init() unless $chdir_init;
+ my $newpwd;
+ if ($^O eq 'MSWin32') {
+ # get the full path name *before* the chdir()
+ $newpwd = Win32::GetFullPathName($newdir);
+ }
+
+ return 0 unless CORE::chdir $newdir;
+
+ if ($^O eq 'VMS') {
+ return $ENV{'PWD'} = $ENV{'DEFAULT'}
+ }
+ elsif ($^O eq 'MacOS') {
+ return $ENV{'PWD'} = cwd();
+ }
+ elsif ($^O eq 'MSWin32') {
+ $ENV{'PWD'} = $newpwd;
+ return 1;
+ }
+
+ if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
+ $ENV{'PWD'} = cwd();
+ } elsif ($newdir =~ m#^/#s) {
+ $ENV{'PWD'} = $newdir;
+ } else {
+ my @curdir = split(m#/#,$ENV{'PWD'});
+ @curdir = ('') unless @curdir;
+ my $component;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ 1;
+}
+
+
+sub _perl_abs_path
+{
+ my $start = @_ ? shift : '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ _carp("stat($start): $!");
+ return '';
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+ # NOTE that this routine assumes that '/' is the only directory separator.
+
+ my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
+ or return cwd() . '/' . $start;
+
+ # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
+ if (-l $start) {
+ my $link_target = readlink($start);
+ die "Can't resolve link $start: $!" unless defined $link_target;
+
+ require File::Spec;
+ $link_target = $dir . '/' . $link_target
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return abs_path($link_target);
+ }
+
+ return $dir ? abs_path($dir) . "/$file" : "/$file";
+ }
+
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ local *PARENT;
+ unless (opendir(PARENT, $dotdots))
+ {
+ # probably a permissions issue. Try the native command.
+ return File::Spec->rel2abs( $start, _backtick_pwd() );
+ }
+ unless (@cst = stat($dotdots))
+ {
+ _carp("stat($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = undef;
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(PARENT)))
+ {
+ _carp("readdir($dotdots): $!");
+ closedir(PARENT);
+ return '';
+ }
+ $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+ $tst[1] != $pst[1]);
+ }
+ $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
+ closedir(PARENT);
+ } while (defined $dir);
+ chop($cwd) unless $cwd eq '/'; # drop the trailing /
+ $cwd;
+}
+
+
+my $Curdir;
+sub fast_abs_path {
+ local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
+ my $cwd = getcwd();
+ require File::Spec;
+ my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
+
+ # Detaint else we'll explode in taint mode. This is safe because
+ # we're not doing anything dangerous with it.
+ ($path) = $path =~ /(.*)/;
+ ($cwd) = $cwd =~ /(.*)/;
+
+ unless (-e $path) {
+ _croak("$path: No such file or directory");
+ }
+
+ unless (-d _) {
+ # Make sure we can be invoked on plain files, not just directories.
+
+ my ($vol, $dir, $file) = File::Spec->splitpath($path);
+ return File::Spec->catfile($cwd, $path) unless length $dir;
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ $link_target = File::Spec->catpath($vol, $dir, $link_target)
+ unless File::Spec->file_name_is_absolute($link_target);
+
+ return fast_abs_path($link_target);
+ }
+
+ return $dir eq File::Spec->rootdir
+ ? File::Spec->catpath($vol, $dir, $file)
+ : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
+ }
+
+ if (!CORE::chdir($path)) {
+ _croak("Cannot chdir to $path: $!");
+ }
+ my $realpath = getcwd();
+ if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
+ _croak("Cannot chdir back to $cwd: $!");
+ }
+ $realpath;
+}
+
+# added function alias to follow principle of least surprise
+# based on previous aliasing. --tchrist 27-Jan-00
+*fast_realpath = \&fast_abs_path;
+
+
+# --- PORTING SECTION ---
+
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
+# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
+# in the process logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
+sub _vms_cwd {
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+ my $path = shift;
+
+ my $efs = _vms_efs;
+ my $unix_rpt = _vms_unix_rpt;
+
+ if (defined &VMS::Filespec::vmsrealpath) {
+ my $path_unix = 0;
+ my $path_vms = 0;
+
+ $path_unix = 1 if ($path =~ m#(?<=\^)/#);
+ $path_unix = 1 if ($path =~ /^\.\.?$/);
+ $path_vms = 1 if ($path =~ m#[\[<\]]#);
+ $path_vms = 1 if ($path =~ /^--?$/);
+
+ my $unix_mode = $path_unix;
+ if ($efs) {
+ # In case of a tie, the Unix report mode decides.
+ if ($path_vms == $path_unix) {
+ $unix_mode = $unix_rpt;
+ } else {
+ $unix_mode = 0 if $path_vms;
+ }
+ }
+
+ if ($unix_mode) {
+ # Unix format
+ return VMS::Filespec::unixrealpath($path);
+ }
+
+ # VMS format
+
+ my $new_path = VMS::Filespec::vmsrealpath($path);
+
+ # Perl expects directories to be in directory format
+ $new_path = VMS::Filespec::pathify($new_path) if -d $path;
+ return $new_path;
+ }
+
+ # Fallback to older algorithm if correct ones are not
+ # available.
+
+ if (-l $path) {
+ my $link_target = readlink($path);
+ die "Can't resolve link $path: $!" unless defined $link_target;
+
+ return _vms_abs_path($link_target);
+ }
+
+ # may need to turn foo.dir into [.foo]
+ my $pathified = VMS::Filespec::pathify($path);
+ $path = $pathified if defined $pathified;
+
+ return VMS::Filespec::rmsexpand($path);
+}
+
+sub _os2_cwd {
+ $ENV{'PWD'} = `cmd /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+sub _win32_cwd {
+ if (eval 'defined &DynaLoader::boot_DynaLoader') {
+ $ENV{'PWD'} = Win32::GetCwd();
+ }
+ else { # miniperl
+ chomp($ENV{'PWD'} = `cd`);
+ }
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
+
+sub _dos_cwd {
+ if (!defined &Dos::GetCwd) {
+ $ENV{'PWD'} = `command /c cd`;
+ chomp $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ } else {
+ $ENV{'PWD'} = Dos::GetCwd();
+ }
+ return $ENV{'PWD'};
+}
+
+sub _qnx_cwd {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ $ENV{'PWD'} = `/usr/bin/fullpath -t`;
+ chomp $ENV{'PWD'};
+ return $ENV{'PWD'};
+}
+
+sub _qnx_abs_path {
+ local $ENV{PATH} = '';
+ local $ENV{CDPATH} = '';
+ local $ENV{ENV} = '';
+ my $path = @_ ? shift : '.';
+ local *REALPATH;
+
+ defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
+ die "Can't open /usr/bin/fullpath: $!";
+ my $realpath = <REALPATH>;
+ close REALPATH;
+ chomp $realpath;
+ return $realpath;
+}
+
+sub _epoc_cwd {
+ $ENV{'PWD'} = EPOC::getcwd();
+ return $ENV{'PWD'};
+}
+
+
+# Now that all the base-level functions are set up, alias the
+# user-level functions to the right places
+
+if (exists $METHOD_MAP{$^O}) {
+ my $map = $METHOD_MAP{$^O};
+ foreach my $name (keys %$map) {
+ local $^W = 0; # assignments trigger 'subroutine redefined' warning
+ no strict 'refs';
+ *{$name} = \&{$map->{$name}};
+ }
+}
+
+# In case the XS version doesn't load.
+*abs_path = \&_perl_abs_path unless defined &abs_path;
+*getcwd = \&_perl_getcwd unless defined &getcwd;
+
+# added function alias for those of us more
+# used to the libc function. --tchrist 27-Jan-00
+*realpath = \&abs_path;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/DB.pm b/Master/tlpkg/tlperl/lib/DB.pm
new file mode 100644
index 00000000000..efb903557a7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DB.pm
@@ -0,0 +1,809 @@
+#
+# Documentation is at the __END__
+#
+
+package DB;
+
+# "private" globals
+
+my ($running, $ready, $deep, $usrctxt, $evalarg,
+ @stack, @saved, @skippkg, @clients);
+my $preeval = {};
+my $posteval = {};
+my $ineval = {};
+
+####
+#
+# Globals - must be defined at startup so that clients can refer to
+# them right after a C<require DB;>
+#
+####
+
+BEGIN {
+
+ # these are hardcoded in perl source (some are magical)
+
+ $DB::sub = ''; # name of current subroutine
+ %DB::sub = (); # "filename:fromline-toline" for every known sub
+ $DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use)
+ $DB::signal = 0; # signal flag (will cause a stop at the next line)
+ $DB::trace = 0; # are we tracing through subroutine calls?
+ @DB::args = (); # arguments of current subroutine or @ARGV array
+ @DB::dbline = (); # list of lines in currently loaded file
+ %DB::dbline = (); # actions in current file (keyed by line number)
+ @DB::ret = (); # return value of last sub executed in list context
+ $DB::ret = ''; # return value of last sub executed in scalar context
+
+ # other "public" globals
+
+ $DB::package = ''; # current package space
+ $DB::filename = ''; # current filename
+ $DB::subname = ''; # currently executing sub (fullly qualified name)
+ $DB::lineno = ''; # current line number
+
+ $DB::VERSION = $DB::VERSION = '1.02';
+
+ # initialize private globals to avoid warnings
+
+ $running = 1; # are we running, or are we stopped?
+ @stack = (0);
+ @clients = ();
+ $deep = 100;
+ $ready = 0;
+ @saved = ();
+ @skippkg = ();
+ $usrctxt = '';
+ $evalarg = '';
+}
+
+####
+# entry point for all subroutine calls
+#
+sub sub {
+ push(@stack, $DB::single);
+ $DB::single &= 1;
+ $DB::single |= 4 if $#stack == $deep;
+ if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
+ &$DB::sub;
+ $DB::single |= pop(@stack);
+ $DB::ret = undef;
+ }
+ elsif (wantarray) {
+ @DB::ret = &$DB::sub;
+ $DB::single |= pop(@stack);
+ @DB::ret;
+ }
+ else {
+ $DB::ret = &$DB::sub;
+ $DB::single |= pop(@stack);
+ $DB::ret;
+ }
+}
+
+####
+# this is called by perl for every statement
+#
+sub DB {
+ return unless $ready;
+ &save;
+ ($DB::package, $DB::filename, $DB::lineno) = caller;
+
+ return if @skippkg and grep { $_ eq $DB::package } @skippkg;
+
+ $usrctxt = "package $DB::package;"; # this won't let them modify, alas
+ local(*DB::dbline) = "::_<$DB::filename";
+
+ # we need to check for pseudofiles on Mac OS (these are files
+ # not attached to a filename, but instead stored in Dev:Pseudo)
+ # since this is done late, $DB::filename will be "wrong" after
+ # skippkg
+ if ($^O eq 'MacOS' && $#DB::dbline < 0) {
+ $DB::filename = 'Dev:Pseudo';
+ *DB::dbline = "::_<$DB::filename";
+ }
+
+ my ($stop, $action);
+ if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
+ if ($stop eq '1') {
+ $DB::signal |= 1;
+ }
+ else {
+ $stop = 0 unless $stop; # avoid un_init warning
+ $evalarg = "\$DB::signal |= do { $stop; }"; &eval;
+ $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt
+ }
+ }
+ if ($DB::single || $DB::trace || $DB::signal) {
+ $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
+ DB->loadfile($DB::filename, $DB::lineno);
+ }
+ $evalarg = $action, &eval if $action;
+ if ($DB::single || $DB::signal) {
+ _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
+ $DB::single = 0;
+ $DB::signal = 0;
+ $running = 0;
+
+ &eval if ($evalarg = DB->prestop);
+ my $c;
+ for $c (@clients) {
+ # perform any client-specific prestop actions
+ &eval if ($evalarg = $c->cprestop);
+
+ # Now sit in an event loop until something sets $running
+ do {
+ $c->idle; # call client event loop; must not block
+ if ($running == 2) { # client wants something eval-ed
+ &eval if ($evalarg = $c->evalcode);
+ $running = 0;
+ }
+ } until $running;
+
+ # perform any client-specific poststop actions
+ &eval if ($evalarg = $c->cpoststop);
+ }
+ &eval if ($evalarg = DB->poststop);
+ }
+ ($@, $!, $,, $/, $\, $^W) = @saved;
+ ();
+}
+
+####
+# this takes its argument via $evalarg to preserve current @_
+#
+sub eval {
+ ($@, $!, $,, $/, $\, $^W) = @saved;
+ eval "$usrctxt $evalarg; &DB::save";
+ _outputall($@) if $@;
+}
+
+###############################################################################
+# no compile-time subroutine call allowed before this point #
+###############################################################################
+
+use strict; # this can run only after DB() and sub() are defined
+
+sub save {
+ @saved = ($@, $!, $,, $/, $\, $^W);
+ $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
+}
+
+sub catch {
+ for (@clients) { $_->awaken; }
+ $DB::signal = 1;
+ $ready = 1;
+}
+
+####
+#
+# Client callable (read inheritable) methods defined after this point
+#
+####
+
+sub register {
+ my $s = shift;
+ $s = _clientname($s) if ref($s);
+ push @clients, $s;
+}
+
+sub done {
+ my $s = shift;
+ $s = _clientname($s) if ref($s);
+ @clients = grep {$_ ne $s} @clients;
+ $s->cleanup;
+# $running = 3 unless @clients;
+ exit(0) unless @clients;
+}
+
+sub _clientname {
+ my $name = shift;
+ "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
+ return $1;
+}
+
+sub next {
+ my $s = shift;
+ $DB::single = 2;
+ $running = 1;
+}
+
+sub step {
+ my $s = shift;
+ $DB::single = 1;
+ $running = 1;
+}
+
+sub cont {
+ my $s = shift;
+ my $i = shift;
+ $s->set_tbreak($i) if $i;
+ for ($i = 0; $i <= $#stack;) {
+ $stack[$i++] &= ~1;
+ }
+ $DB::single = 0;
+ $running = 1;
+}
+
+####
+# XXX caller must experimentally determine $i (since it depends
+# on how many client call frames are between this call and the DB call).
+# Such is life.
+#
+sub ret {
+ my $s = shift;
+ my $i = shift; # how many levels to get to DB sub
+ $i = 0 unless defined $i;
+ $stack[$#stack-$i] |= 1;
+ $DB::single = 0;
+ $running = 1;
+}
+
+####
+# XXX caller must experimentally determine $start (since it depends
+# on how many client call frames are between this call and the DB call).
+# Such is life.
+#
+sub backtrace {
+ my $self = shift;
+ my $start = shift;
+ my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
+ $start = 1 unless $start;
+ for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
+ @a = @DB::args;
+ for (@a) {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+ $e =~ s/[\\\']/\\$1/g if $e;
+ if ($r) {
+ $s = "require '$e'";
+ } elsif (defined $r) {
+ $s = "eval '$e'";
+ } elsif ($s eq '(eval)') {
+ $s = "eval {...}";
+ }
+ $f = "file `$f'" unless $f eq '-e';
+ push @ret, "$w&$s$a from $f line $l";
+ last if $DB::signal;
+ }
+ return @ret;
+}
+
+sub _outputall {
+ my $c;
+ for $c (@clients) {
+ $c->output(@_);
+ }
+}
+
+sub trace_toggle {
+ my $s = shift;
+ $DB::trace = !$DB::trace;
+}
+
+
+####
+# without args: returns all defined subroutine names
+# with subname args: returns a listref [file, start, end]
+#
+sub subs {
+ my $s = shift;
+ if (@_) {
+ my(@ret) = ();
+ while (@_) {
+ my $name = shift;
+ push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
+ if exists $DB::sub{$name};
+ }
+ return @ret;
+ }
+ return keys %DB::sub;
+}
+
+####
+# first argument is a filename whose subs will be returned
+# if a filename is not supplied, all subs in the current
+# filename are returned.
+#
+sub filesubs {
+ my $s = shift;
+ my $fname = shift;
+ $fname = $DB::filename unless $fname;
+ return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
+}
+
+####
+# returns a list of all filenames that DB knows about
+#
+sub files {
+ my $s = shift;
+ my(@f) = grep(m|^_<|, keys %main::);
+ return map { substr($_,2) } @f;
+}
+
+####
+# returns reference to an array holding the lines in currently
+# loaded file
+#
+sub lines {
+ my $s = shift;
+ return \@DB::dbline;
+}
+
+####
+# loadfile($file, $line)
+#
+sub loadfile {
+ my $s = shift;
+ my($file, $line) = @_;
+ if (!defined $main::{'_<' . $file}) {
+ my $try;
+ if (($try) = grep(m|^_<.*$file|, keys %main::)) {
+ $file = substr($try,2);
+ }
+ }
+ if (defined($main::{'_<' . $file})) {
+ my $c;
+# _outputall("Loading file $file..");
+ *DB::dbline = "::_<$file";
+ $DB::filename = $file;
+ for $c (@clients) {
+# print "2 ", $file, '|', $line, "\n";
+ $c->showfile($file, $line);
+ }
+ return $file;
+ }
+ return undef;
+}
+
+sub lineevents {
+ my $s = shift;
+ my $fname = shift;
+ my(%ret) = ();
+ my $i;
+ $fname = $DB::filename unless $fname;
+ local(*DB::dbline) = "::_<$fname";
+ for ($i = 1; $i <= $#DB::dbline; $i++) {
+ $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
+ if defined $DB::dbline{$i};
+ }
+ return %ret;
+}
+
+sub set_break {
+ my $s = shift;
+ my $i = shift;
+ my $cond = shift;
+ $i ||= $DB::lineno;
+ $cond ||= '1';
+ $i = _find_subline($i) if ($i =~ /\D/);
+ $s->output("Subroutine not found.\n") unless $i;
+ if ($i) {
+ if ($DB::dbline[$i] == 0) {
+ $s->output("Line $i not breakable.\n");
+ }
+ else {
+ $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ }
+}
+
+sub set_tbreak {
+ my $s = shift;
+ my $i = shift;
+ $i = _find_subline($i) if ($i =~ /\D/);
+ $s->output("Subroutine not found.\n") unless $i;
+ if ($i) {
+ if ($DB::dbline[$i] == 0) {
+ $s->output("Line $i not breakable.\n");
+ }
+ else {
+ $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ }
+ }
+}
+
+sub _find_subline {
+ my $name = shift;
+ $name =~ s/\'/::/;
+ $name = "${DB::package}\:\:" . $name if $name !~ /::/;
+ $name = "main" . $name if substr($name,0,2) eq "::";
+ my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
+ if ($from) {
+ local *DB::dbline = "::_<$fname";
+ ++$from while $DB::dbline[$from] == 0 && $from < $to;
+ return $from;
+ }
+ return undef;
+}
+
+sub clr_breaks {
+ my $s = shift;
+ my $i;
+ if (@_) {
+ while (@_) {
+ $i = shift;
+ $i = _find_subline($i) if ($i =~ /\D/);
+ $s->output("Subroutine not found.\n") unless $i;
+ if (defined $DB::dbline{$i}) {
+ $DB::dbline{$i} =~ s/^[^\0]+//;
+ if ($DB::dbline{$i} =~ s/^\0?$//) {
+ delete $DB::dbline{$i};
+ }
+ }
+ }
+ }
+ else {
+ for ($i = 1; $i <= $#DB::dbline ; $i++) {
+ if (defined $DB::dbline{$i}) {
+ $DB::dbline{$i} =~ s/^[^\0]+//;
+ if ($DB::dbline{$i} =~ s/^\0?$//) {
+ delete $DB::dbline{$i};
+ }
+ }
+ }
+ }
+}
+
+sub set_action {
+ my $s = shift;
+ my $i = shift;
+ my $act = shift;
+ $i = _find_subline($i) if ($i =~ /\D/);
+ $s->output("Subroutine not found.\n") unless $i;
+ if ($i) {
+ if ($DB::dbline[$i] == 0) {
+ $s->output("Line $i not actionable.\n");
+ }
+ else {
+ $DB::dbline{$i} =~ s/\0[^\0]*//;
+ $DB::dbline{$i} .= "\0" . $act;
+ }
+ }
+}
+
+sub clr_actions {
+ my $s = shift;
+ my $i;
+ if (@_) {
+ while (@_) {
+ my $i = shift;
+ $i = _find_subline($i) if ($i =~ /\D/);
+ $s->output("Subroutine not found.\n") unless $i;
+ if ($i && $DB::dbline[$i] != 0) {
+ $DB::dbline{$i} =~ s/\0[^\0]*//;
+ delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
+ }
+ }
+ }
+ else {
+ for ($i = 1; $i <= $#DB::dbline ; $i++) {
+ if (defined $DB::dbline{$i}) {
+ $DB::dbline{$i} =~ s/\0[^\0]*//;
+ delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
+ }
+ }
+ }
+}
+
+sub prestop {
+ my ($client, $val) = @_;
+ return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
+}
+
+sub poststop {
+ my ($client, $val) = @_;
+ return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
+}
+
+#
+# "pure virtual" methods
+#
+
+# client-specific pre/post-stop actions.
+sub cprestop {}
+sub cpoststop {}
+
+# client complete startup
+sub awaken {}
+
+sub skippkg {
+ my $s = shift;
+ push @skippkg, @_ if @_;
+}
+
+sub evalcode {
+ my ($client, $val) = @_;
+ if (defined $val) {
+ $running = 2; # hand over to DB() to evaluate in its context
+ $ineval->{$client} = $val;
+ }
+ return $ineval->{$client};
+}
+
+sub ready {
+ my $s = shift;
+ return $ready = 1;
+}
+
+# stubs
+
+sub init {}
+sub stop {}
+sub idle {}
+sub cleanup {}
+sub output {}
+
+#
+# client init
+#
+for (@clients) { $_->init }
+
+$SIG{'INT'} = \&DB::catch;
+
+# disable this if stepping through END blocks is desired
+# (looks scary and deconstructivist with Swat)
+END { $ready = 0 }
+
+1;
+__END__
+
+=head1 NAME
+
+DB - programmatic interface to the Perl debugging API
+
+=head1 SYNOPSIS
+
+ package CLIENT;
+ use DB;
+ @ISA = qw(DB);
+
+ # these (inherited) methods can be called by the client
+
+ CLIENT->register() # register a client package name
+ CLIENT->done() # de-register from the debugging API
+ CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
+ CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt)
+ CLIENT->step() # single step
+ CLIENT->next() # step over
+ CLIENT->ret() # return from current subroutine
+ CLIENT->backtrace() # return the call stack description
+ CLIENT->ready() # call when client setup is done
+ CLIENT->trace_toggle() # toggle subroutine call trace mode
+ CLIENT->subs([SUBS]) # return subroutine information
+ CLIENT->files() # return list of all files known to DB
+ CLIENT->lines() # return lines in currently loaded file
+ CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
+ CLIENT->lineevents() # return info on lines with actions
+ CLIENT->set_break([WHERE],[COND])
+ CLIENT->set_tbreak([WHERE])
+ CLIENT->clr_breaks([LIST])
+ CLIENT->set_action(WHERE,ACTION)
+ CLIENT->clr_actions([LIST])
+ CLIENT->evalcode(STRING) # eval STRING in executing code's context
+ CLIENT->prestop([STRING]) # execute in code context before stopping
+ CLIENT->poststop([STRING])# execute in code context before resuming
+
+ # These methods will be called at the appropriate times.
+ # Stub versions provided do nothing.
+ # None of these can block.
+
+ CLIENT->init() # called when debug API inits itself
+ CLIENT->stop(FILE,LINE) # when execution stops
+ CLIENT->idle() # while stopped (can be a client event loop)
+ CLIENT->cleanup() # just before exit
+ CLIENT->output(LIST) # called to print any output that API must show
+
+=head1 DESCRIPTION
+
+Perl debug information is frequently required not just by debuggers,
+but also by modules that need some "special" information to do their
+job properly, like profilers.
+
+This module abstracts and provides all of the hooks into Perl internal
+debugging functionality, so that various implementations of Perl debuggers
+(or packages that want to simply get at the "privileged" debugging data)
+can all benefit from the development of this common code. Currently used
+by Swat, the perl/Tk GUI debugger.
+
+Note that multiple "front-ends" can latch into this debugging API
+simultaneously. This is intended to facilitate things like
+debugging with a command line and GUI at the same time, debugging
+debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
+
+In particular, this API does B<not> provide the following functions:
+
+=over 4
+
+=item *
+
+data display
+
+=item *
+
+command processing
+
+=item *
+
+command alias management
+
+=item *
+
+user interface (tty or graphical)
+
+=back
+
+These are intended to be services performed by the clients of this API.
+
+This module attempts to be squeaky clean w.r.t C<use strict;> and when
+warnings are enabled.
+
+
+=head2 Global Variables
+
+The following "public" global names can be read by clients of this API.
+Beware that these should be considered "readonly".
+
+=over 8
+
+=item $DB::sub
+
+Name of current executing subroutine.
+
+=item %DB::sub
+
+The keys of this hash are the names of all the known subroutines. Each value
+is an encoded string that has the sprintf(3) format
+C<("%s:%d-%d", filename, fromline, toline)>.
+
+=item $DB::single
+
+Single-step flag. Will be true if the API will stop at the next statement.
+
+=item $DB::signal
+
+Signal flag. Will be set to a true value if a signal was caught. Clients may
+check for this flag to abort time-consuming operations.
+
+=item $DB::trace
+
+This flag is set to true if the API is tracing through subroutine calls.
+
+=item @DB::args
+
+Contains the arguments of current subroutine, or the C<@ARGV> array if in the
+toplevel context.
+
+=item @DB::dbline
+
+List of lines in currently loaded file.
+
+=item %DB::dbline
+
+Actions in current file (keys are line numbers). The values are strings that
+have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
+
+=item $DB::package
+
+Package namespace of currently executing code.
+
+=item $DB::filename
+
+Currently loaded filename.
+
+=item $DB::subname
+
+Fully qualified name of currently executing subroutine.
+
+=item $DB::lineno
+
+Line number that will be executed next.
+
+=back
+
+=head2 API Methods
+
+The following are methods in the DB base class. A client must
+access these methods by inheritance (*not* by calling them directly),
+since the API keeps track of clients through the inheritance
+mechanism.
+
+=over 8
+
+=item CLIENT->register()
+
+register a client object/package
+
+=item CLIENT->evalcode(STRING)
+
+eval STRING in executing code context
+
+=item CLIENT->skippkg('D::hide')
+
+ask DB not to stop in these packages
+
+=item CLIENT->run()
+
+run some more (until a breakpt is reached)
+
+=item CLIENT->step()
+
+single step
+
+=item CLIENT->next()
+
+step over
+
+=item CLIENT->done()
+
+de-register from the debugging API
+
+=back
+
+=head2 Client Callback Methods
+
+The following "virtual" methods can be defined by the client. They will
+be called by the API at appropriate points. Note that unless specified
+otherwise, the debug API only defines empty, non-functional default versions
+of these methods.
+
+=over 8
+
+=item CLIENT->init()
+
+Called after debug API inits itself.
+
+=item CLIENT->prestop([STRING])
+
+Usually inherited from DB package. If no arguments are passed,
+returns the prestop action string.
+
+=item CLIENT->stop()
+
+Called when execution stops (w/ args file, line).
+
+=item CLIENT->idle()
+
+Called while stopped (can be a client event loop).
+
+=item CLIENT->poststop([STRING])
+
+Usually inherited from DB package. If no arguments are passed,
+returns the poststop action string.
+
+=item CLIENT->evalcode(STRING)
+
+Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
+in executing code context.
+
+=item CLIENT->cleanup()
+
+Called just before exit.
+
+=item CLIENT->output(LIST)
+
+Called when API must show a message (warnings, errors etc.).
+
+
+=back
+
+
+=head1 BUGS
+
+The interface defined by this module is missing some of the later additions
+to perl's debugging functionality. As such, this interface should be considered
+highly experimental and subject to change.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@activestate.com
+
+This code heavily adapted from an early version of perl5db.pl attributable
+to Larry Wall and the Perl Porters.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/DBM_Filter.pm b/Master/tlpkg/tlperl/lib/DBM_Filter.pm
new file mode 100644
index 00000000000..abcc127ba0a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DBM_Filter.pm
@@ -0,0 +1,605 @@
+package DBM_Filter ;
+
+use strict;
+use warnings;
+our $VERSION = '0.03';
+
+package Tie::Hash ;
+
+use strict;
+use warnings;
+
+use Carp;
+
+
+our %LayerStack = ();
+our %origDESTROY = ();
+
+our %Filters = map { $_, undef } qw(
+ Fetch_Key
+ Fetch_Value
+ Store_Key
+ Store_Value
+ );
+
+our %Options = map { $_, 1 } qw(
+ fetch
+ store
+ );
+
+#sub Filter_Enable
+#{
+#}
+#
+#sub Filter_Disable
+#{
+#}
+
+sub Filtered
+{
+ my $this = shift;
+ return defined $LayerStack{$this} ;
+}
+
+sub Filter_Pop
+{
+ my $this = shift;
+ my $stack = $LayerStack{$this} || return undef ;
+ my $filter = pop @{ $stack };
+
+ # remove the filter hooks if this is the last filter to pop
+ if ( @{ $stack } == 0 ) {
+ $this->filter_store_key ( undef );
+ $this->filter_store_value( undef );
+ $this->filter_fetch_key ( undef );
+ $this->filter_fetch_value( undef );
+ delete $LayerStack{$this};
+ }
+
+ return $filter;
+}
+
+sub Filter_Key_Push
+{
+ &_do_Filter_Push;
+}
+
+sub Filter_Value_Push
+{
+ &_do_Filter_Push;
+}
+
+
+sub Filter_Push
+{
+ &_do_Filter_Push;
+}
+
+sub _do_Filter_Push
+{
+ my $this = shift;
+ my %callbacks = ();
+ my $caller = (caller(1))[3];
+ $caller =~ s/^.*:://;
+
+ croak "$caller: no parameters present" unless @_ ;
+
+ if ( ! $Options{lc $_[0]} ) {
+ my $class = shift;
+ my @params = @_;
+
+ # if $class already contains "::", don't prefix "DBM_Filter::"
+ $class = "DBM_Filter::$class" unless $class =~ /::/;
+
+ no strict 'refs';
+ # does the "DBM_Filter::$class" exist?
+ if ( ! %{ "${class}::"} ) {
+ # Nope, so try to load it.
+ eval " require $class ; " ;
+ croak "$caller: Cannot Load DBM Filter '$class': $@" if $@;
+ }
+
+ my $fetch = *{ "${class}::Fetch" }{CODE};
+ my $store = *{ "${class}::Store" }{CODE};
+ my $filter = *{ "${class}::Filter" }{CODE};
+ use strict 'refs';
+
+ my $count = defined($filter) + defined($store) + defined($fetch) ;
+
+ if ( $count == 0 )
+ { croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" }
+ elsif ( $count == 1 && ! defined $filter) {
+ my $need = defined($fetch) ? 'Store' : 'Fetch';
+ croak "$caller: Missing method '$need' in class '$class'" ;
+ }
+ elsif ( $count >= 2 && defined $filter)
+ { croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" }
+
+ if (defined $filter) {
+ my $callbacks = &{ $filter }(@params);
+ croak "$caller: '${class}::Filter' did not return a hash reference"
+ unless ref $callbacks && ref $callbacks eq 'HASH';
+ %callbacks = %{ $callbacks } ;
+ }
+ else {
+ $callbacks{Fetch} = $fetch;
+ $callbacks{Store} = $store;
+ }
+ }
+ else {
+ croak "$caller: not even params" unless @_ % 2 == 0;
+ %callbacks = @_;
+ }
+
+ my %filters = %Filters ;
+ my @got = ();
+ while (my ($k, $v) = each %callbacks )
+ {
+ my $key = $k;
+ $k = lc $k;
+ if ($k eq 'fetch') {
+ push @got, 'Fetch';
+ if ($caller eq 'Filter_Push')
+ { $filters{Fetch_Key} = $filters{Fetch_Value} = $v }
+ elsif ($caller eq 'Filter_Key_Push')
+ { $filters{Fetch_Key} = $v }
+ elsif ($caller eq 'Filter_Value_Push')
+ { $filters{Fetch_Value} = $v }
+ }
+ elsif ($k eq 'store') {
+ push @got, 'Store';
+ if ($caller eq 'Filter_Push')
+ { $filters{Store_Key} = $filters{Store_Value} = $v }
+ elsif ($caller eq 'Filter_Key_Push')
+ { $filters{Store_Key} = $v }
+ elsif ($caller eq 'Filter_Value_Push')
+ { $filters{Store_Value} = $v }
+ }
+ else
+ { croak "$caller: Unknown key '$key'" }
+
+ croak "$caller: value associated with key '$key' is not a code reference"
+ unless ref $v && ref $v eq 'CODE';
+ }
+
+ if ( @got != 2 ) {
+ push @got, 'neither' if @got == 0 ;
+ croak "$caller: expected both Store & Fetch - got @got";
+ }
+
+ # remember the class
+ push @{ $LayerStack{$this} }, \%filters ;
+
+ my $str_this = "$this" ; # Avoid a closure with $this in the subs below
+
+ $this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') });
+ $this->filter_store_value( sub { store_hook($str_this, 'Store_Value') });
+ $this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') });
+ $this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') });
+
+ # Hijack the callers DESTROY method
+ $this =~ /^(.*)=/;
+ my $type = $1 ;
+ no strict 'refs';
+ if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY )
+ {
+ $origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE};
+ no warnings 'redefine';
+ *{ "${type}::DESTROY" } = \&MyDESTROY ;
+ }
+}
+
+sub store_hook
+{
+ my $this = shift ;
+ my $type = shift ;
+ foreach my $layer (@{ $LayerStack{$this} })
+ {
+ &{ $layer->{$type} }() if defined $layer->{$type} ;
+ }
+}
+
+sub fetch_hook
+{
+ my $this = shift ;
+ my $type = shift ;
+ foreach my $layer (reverse @{ $LayerStack{$this} })
+ {
+ &{ $layer->{$type} }() if defined $layer->{$type} ;
+ }
+}
+
+sub MyDESTROY
+{
+ my $this = shift ;
+ delete $LayerStack{$this} ;
+
+ # call real DESTROY
+ $this =~ /^(.*)=/;
+ &{ $origDESTROY{$1} }($this);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBM_Filter -- Filter DBM keys/values
+
+=head1 SYNOPSIS
+
+ use DBM_Filter ;
+ use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
+
+ $db = tie %hash, ...
+
+ $db->Filter_Push(Fetch => sub {...},
+ Store => sub {...});
+
+ $db->Filter_Push('my_filter1');
+ $db->Filter_Push('my_filter2', params...);
+
+ $db->Filter_Key_Push(...) ;
+ $db->Filter_Value_Push(...) ;
+
+ $db->Filter_Pop();
+ $db->Filtered();
+
+ package DBM_Filter::my_filter1;
+
+ sub Store { ... }
+ sub Fetch { ... }
+
+ 1;
+
+ package DBM_Filter::my_filter2;
+
+ sub Filter
+ {
+ my @opts = @_;
+ ...
+ return (
+ sub Store { ... },
+ sub Fetch { ... } );
+ }
+
+ 1;
+
+=head1 DESCRIPTION
+
+This module provides an interface that allows filters to be applied
+to tied Hashes associated with DBM files. It builds on the DBM Filter
+hooks that are present in all the *DB*_File modules included with the
+standard Perl source distribution from version 5.6.1 onwards. In addition
+to the *DB*_File modules distributed with Perl, the BerkeleyDB module,
+available on CPAN, supports the DBM Filter hooks. See L<perldbmfilter>
+for more details on the DBM Filter hooks.
+
+=head1 What is a DBM Filter?
+
+A DBM Filter allows the keys and/or values in a tied hash to be modified
+by some user-defined code just before it is written to the DBM file and
+just after it is read back from the DBM file. For example, this snippet
+of code
+
+ $some_hash{"abc"} = 42;
+
+could potentially trigger two filters, one for the writing of the key
+"abc" and another for writing the value 42. Similarly, this snippet
+
+ my ($key, $value) = each %some_hash
+
+will trigger two filters, one for the reading of the key and one for
+the reading of the value.
+
+Like the existing DBM Filter functionality, this module arranges for the
+C<$_> variable to be populated with the key or value that a filter will
+check. This usually means that most DBM filters tend to be very short.
+
+=head2 So what's new?
+
+The main enhancements over the standard DBM Filter hooks are:
+
+=over 4
+
+=item *
+
+A cleaner interface.
+
+=item *
+
+The ability to easily apply multiple filters to a single DBM file.
+
+=item *
+
+The ability to create "canned" filters. These allow commonly used filters
+to be packaged into a stand-alone module.
+
+=back
+
+=head1 METHODS
+
+This module will arrange for the following methods to be available via
+the object returned from the C<tie> call.
+
+=head2 $db->Filter_Push()
+
+=head2 $db->Filter_Key_Push()
+
+=head2 $db->Filter_Value_Push()
+
+Add a filter to filter stack for the database, C<$db>. The three formats
+vary only in whether they apply to the DBM key, the DBM value or both.
+
+=over 5
+
+=item Filter_Push
+
+The filter is applied to I<both> keys and values.
+
+=item Filter_Key_Push
+
+The filter is applied to the key I<only>.
+
+=item Filter_Value_Push
+
+The filter is applied to the value I<only>.
+
+=back
+
+
+=head2 $db->Filter_Pop()
+
+Removes the last filter that was applied to the DBM file associated with
+C<$db>, if present.
+
+=head2 $db->Filtered()
+
+Returns TRUE if there are any filters applied to the DBM associated
+with C<$db>. Otherwise returns FALSE.
+
+
+
+=head1 Writing a Filter
+
+Filters can be created in two main ways
+
+=head2 Immediate Filters
+
+An immediate filter allows you to specify the filter code to be used
+at the point where the filter is applied to a dbm. In this mode the
+Filter_*_Push methods expects to receive exactly two parameters.
+
+ my $db = tie %hash, 'SDBM_File', ...
+ $db->Filter_Push( Store => sub { },
+ Fetch => sub { });
+
+The code reference associated with C<Store> will be called before any
+key/value is written to the database and the code reference associated
+with C<Fetch> will be called after any key/value is read from the
+database.
+
+For example, here is a sample filter that adds a trailing NULL character
+to all strings before they are written to the DBM file, and removes the
+trailing NULL when they are read from the DBM file
+
+ my $db = tie %hash, 'SDBM_File', ...
+ $db->Filter_Push( Store => sub { $_ .= "\x00" ; },
+ Fetch => sub { s/\x00$// ; });
+
+
+Points to note:
+
+=over 5
+
+=item 1.
+
+Both the Store and Fetch filters manipulate C<$_>.
+
+=back
+
+=head2 Canned Filters
+
+Immediate filters are useful for one-off situations. For more generic
+problems it can be useful to package the filter up in its own module.
+
+The usage is for a canned filter is:
+
+ $db->Filter_Push("name", params)
+
+where
+
+=over 5
+
+=item "name"
+
+is the name of the module to load. If the string specified does not
+contain the package separator characters "::", it is assumed to refer to
+the full module name "DBM_Filter::name". This means that the full names
+for canned filters, "null" and "utf8", included with this module are:
+
+ DBM_Filter::null
+ DBM_Filter::utf8
+
+=item params
+
+any optional parameters that need to be sent to the filter. See the
+encode filter for an example of a module that uses parameters.
+
+=back
+
+The module that implements the canned filter can take one of two
+forms. Here is a template for the first
+
+ package DBM_Filter::null ;
+
+ use strict;
+ use warnings;
+
+ sub Store
+ {
+ # store code here
+ }
+
+ sub Fetch
+ {
+ # fetch code here
+ }
+
+ 1;
+
+
+Notes:
+
+=over 5
+
+=item 1.
+
+The package name uses the C<DBM_Filter::> prefix.
+
+=item 2.
+
+The module I<must> have both a Store and a Fetch method. If only one is
+present, or neither are present, a fatal error will be thrown.
+
+=back
+
+The second form allows the filter to hold state information using a
+closure, thus:
+
+ package DBM_Filter::encoding ;
+
+ use strict;
+ use warnings;
+
+ sub Filter
+ {
+ my @params = @_ ;
+
+ ...
+ return {
+ Store => sub { $_ = $encoding->encode($_) },
+ Fetch => sub { $_ = $encoding->decode($_) }
+ } ;
+ }
+
+ 1;
+
+
+In this instance the "Store" and "Fetch" methods are encapsulated inside a
+"Filter" method.
+
+
+=head1 Filters Included
+
+A number of canned filers are provided with this module. They cover a
+number of the main areas that filters are needed when interfacing with
+DBM files. They also act as templates for your own filters.
+
+The filter included are:
+
+=over 5
+
+=item * utf8
+
+This module will ensure that all data written to the DBM will be encoded
+in UTF-8.
+
+This module needs the Encode module.
+
+=item * encode
+
+Allows you to choose the character encoding will be store in the DBM file.
+
+=item * compress
+
+This filter will compress all data before it is written to the database
+and uncompressed it on reading.
+
+This module needs Compress::Zlib.
+
+=item * int32
+
+This module 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.
+
+=item * null
+
+This module 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.
+
+=back
+
+=head1 NOTES
+
+=head2 Maintain Round Trip Integrity
+
+When writing a DBM filter it is I<very> important to ensure that it is
+possible to retrieve all data that you have written when the DBM filter
+is in place. In practice, this means that whatever transformation is
+applied to the data in the Store method, the I<exact> inverse operation
+should be applied in the Fetch method.
+
+If you don't provide an exact inverse transformation, you will find that
+code like this will not behave as you expect.
+
+ while (my ($k, $v) = each %hash)
+ {
+ ...
+ }
+
+Depending on the transformation, you will find that one or more of the
+following will happen
+
+=over 5
+
+=item 1
+
+The loop will never terminate.
+
+=item 2
+
+Too few records will be retrieved.
+
+=item 3
+
+Too many will be retrieved.
+
+=item 4
+
+The loop will do the right thing for a while, but it will unexpectedly fail.
+
+=back
+
+=head2 Don't mix filtered & non-filtered data in the same database file.
+
+This is just a restatement of the previous section. Unless you are
+completely certain you know what you are doing, avoid mixing filtered &
+non-filtered data.
+
+=head1 EXAMPLE
+
+Say you need to interoperate with a legacy C application that stores
+keys as C ints and the values and null terminated UTF-8 strings. Here
+is how you would set that up
+
+ my $db = tie %hash, 'SDBM_File', ...
+
+ $db->Filter_Key_Push('int32') ;
+
+ $db->Filter_Value_Push('utf8');
+ $db->Filter_Value_Push('null');
+
+=head1 SEE ALSO
+
+<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File>, L<SDBM_File>, L<perldbmfilter>
+
+=head1 AUTHOR
+
+Paul Marquess <pmqs@cpan.org>
+
diff --git a/Master/tlpkg/tlperl/lib/Digest.pm b/Master/tlpkg/tlperl/lib/Digest.pm
new file mode 100644
index 00000000000..384dfc82668
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Digest.pm
@@ -0,0 +1,316 @@
+package Digest;
+
+use strict;
+use vars qw($VERSION %MMAP $AUTOLOAD);
+
+$VERSION = "1.16";
+
+%MMAP = (
+ "SHA-1" => [["Digest::SHA", 1], "Digest::SHA1", ["Digest::SHA2", 1]],
+ "SHA-224" => [["Digest::SHA", 224]],
+ "SHA-256" => [["Digest::SHA", 256], ["Digest::SHA2", 256]],
+ "SHA-384" => [["Digest::SHA", 384], ["Digest::SHA2", 384]],
+ "SHA-512" => [["Digest::SHA", 512], ["Digest::SHA2", 512]],
+ "HMAC-MD5" => "Digest::HMAC_MD5",
+ "HMAC-SHA-1" => "Digest::HMAC_SHA1",
+ "CRC-16" => [["Digest::CRC", type => "crc16"]],
+ "CRC-32" => [["Digest::CRC", type => "crc32"]],
+ "CRC-CCITT" => [["Digest::CRC", type => "crcccitt"]],
+ "RIPEMD-160" => "Crypt::PIPEMD160",
+);
+
+sub new
+{
+ shift; # class ignored
+ my $algorithm = shift;
+ my $impl = $MMAP{$algorithm} || do {
+ $algorithm =~ s/\W+//;
+ "Digest::$algorithm";
+ };
+ $impl = [$impl] unless ref($impl);
+ my $err;
+ for (@$impl) {
+ my $class = $_;
+ my @args;
+ ($class, @args) = @$class if ref($class);
+ no strict 'refs';
+ unless (exists ${"$class\::"}{"VERSION"}) {
+ eval "require $class";
+ if ($@) {
+ $err ||= $@;
+ next;
+ }
+ }
+ return $class->new(@args, @_);
+ }
+ die $err;
+}
+
+sub AUTOLOAD
+{
+ my $class = shift;
+ my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+ $class->new($algorithm, @_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Digest - Modules that calculate message digests
+
+=head1 SYNOPSIS
+
+ $md5 = Digest->new("MD5");
+ $sha1 = Digest->new("SHA-1");
+ $sha256 = Digest->new("SHA-256");
+ $sha384 = Digest->new("SHA-384");
+ $sha512 = Digest->new("SHA-512");
+
+ $hmac = Digest->HMAC_MD5($key);
+
+=head1 DESCRIPTION
+
+The C<Digest::> modules calculate digests, also called "fingerprints"
+or "hashes", of some data, called a message. The digest is (usually)
+some small/fixed size string. The actual size of the digest depend of
+the algorithm used. The message is simply a sequence of arbitrary
+bytes or bits.
+
+An important property of the digest algorithms is that the digest is
+I<likely> to change if the message change in some way. Another
+property is that digest functions are one-way functions, that is it
+should be I<hard> to find a message that correspond to some given
+digest. Algorithms differ in how "likely" and how "hard", as well as
+how efficient they are to compute.
+
+Note that the properties of the algorithms change over time, as the
+algorithms are analyzed and machines grow faster. If your application
+for instance depends on it being "impossible" to generate the same
+digest for a different message it is wise to make it easy to plug in
+stronger algorithms as the one used grow weaker. Using the interface
+documented here should make it easy to change algorithms later.
+
+All C<Digest::> modules provide the same programming interface. A
+functional interface for simple use, as well as an object oriented
+interface that can handle messages of arbitrary length and which can
+read files directly.
+
+The digest can be delivered in three formats:
+
+=over 8
+
+=item I<binary>
+
+This is the most compact form, but it is not well suited for printing
+or embedding in places that can't handle arbitrary data.
+
+=item I<hex>
+
+A twice as long string of lowercase hexadecimal digits.
+
+=item I<base64>
+
+A string of portable printable characters. This is the base64 encoded
+representation of the digest with any trailing padding removed. The
+string will be about 30% longer than the binary version.
+L<MIME::Base64> tells you more about this encoding.
+
+=back
+
+
+The functional interface is simply importable functions with the same
+name as the algorithm. The functions take the message as argument and
+return the digest. Example:
+
+ use Digest::MD5 qw(md5);
+ $digest = md5($message);
+
+There are also versions of the functions with "_hex" or "_base64"
+appended to the name, which returns the digest in the indicated form.
+
+=head1 OO INTERFACE
+
+The following methods are available for all C<Digest::> modules:
+
+=over 4
+
+=item $ctx = Digest->XXX($arg,...)
+
+=item $ctx = Digest->new(XXX => $arg,...)
+
+=item $ctx = Digest::XXX->new($arg,...)
+
+The constructor returns some object that encapsulate the state of the
+message-digest algorithm. You can add data to the object and finally
+ask for the digest. The "XXX" should of course be replaced by the proper
+name of the digest algorithm you want to use.
+
+The two first forms are simply syntactic sugar which automatically
+load the right module on first use. The second form allow you to use
+algorithm names which contains letters which are not legal perl
+identifiers, e.g. "SHA-1". If no implementation for the given algorithm
+can be found, then an exception is raised.
+
+If new() is called as an instance method (i.e. $ctx->new) it will just
+reset the state the object to the state of a newly created object. No
+new object is created in this case, and the return value is the
+reference to the object (i.e. $ctx).
+
+=item $other_ctx = $ctx->clone
+
+The clone method creates a copy of the digest state object and returns
+a reference to the copy.
+
+=item $ctx->reset
+
+This is just an alias for $ctx->new.
+
+=item $ctx->add( $data )
+
+=item $ctx->add( $chunk1, $chunk2, ... )
+
+The string value of the $data provided as argument is appended to the
+message we calculate the digest for. The return value is the $ctx
+object itself.
+
+If more arguments are provided then they are all appended to the
+message, thus all these lines will have the same effect on the state
+of the $ctx object:
+
+ $ctx->add("a"); $ctx->add("b"); $ctx->add("c");
+ $ctx->add("a")->add("b")->add("c");
+ $ctx->add("a", "b", "c");
+ $ctx->add("abc");
+
+Most algorithms are only defined for strings of bytes and this method
+might therefore croak if the provided arguments contain chars with
+ordinal number above 255.
+
+=item $ctx->addfile( $io_handle )
+
+The $io_handle is read until EOF and the content is appended to the
+message we calculate the digest for. The return value is the $ctx
+object itself.
+
+The addfile() method will croak() if it fails reading data for some
+reason. If it croaks it is unpredictable what the state of the $ctx
+object will be in. The addfile() method might have been able to read
+the file partially before it failed. It is probably wise to discard
+or reset the $ctx object if this occurs.
+
+In most cases you want to make sure that the $io_handle is in
+"binmode" before you pass it as argument to the addfile() method.
+
+=item $ctx->add_bits( $data, $nbits )
+
+=item $ctx->add_bits( $bitstring )
+
+The add_bits() method is an alternative to add() that allow partial
+bytes to be appended to the message. Most users should just ignore
+this method as partial bytes is very unlikely to be of any practical
+use.
+
+The two argument form of add_bits() will add the first $nbits bits
+from $data. For the last potentially partial byte only the high order
+C<< $nbits % 8 >> bits are used. If $nbits is greater than C<<
+length($data) * 8 >>, then this method would do the same as C<<
+$ctx->add($data) >>.
+
+The one argument form of add_bits() takes a $bitstring of "1" and "0"
+chars as argument. It's a shorthand for C<< $ctx->add_bits(pack("B*",
+$bitstring), length($bitstring)) >>.
+
+The return value is the $ctx object itself.
+
+This example shows two calls that should have the same effect:
+
+ $ctx->add_bits("111100001010");
+ $ctx->add_bits("\xF0\xA0", 12);
+
+Most digest algorithms are byte based and for these it is not possible
+to add bits that are not a multiple of 8, and the add_bits() method
+will croak if you try.
+
+=item $ctx->digest
+
+Return the binary digest for the message.
+
+Note that the C<digest> operation is effectively a destructive,
+read-once operation. Once it has been performed, the $ctx object is
+automatically C<reset> and can be used to calculate another digest
+value. Call $ctx->clone->digest if you want to calculate the digest
+without resetting the digest state.
+
+=item $ctx->hexdigest
+
+Same as $ctx->digest, but will return the digest in hexadecimal form.
+
+=item $ctx->b64digest
+
+Same as $ctx->digest, but will return the digest as a base64 encoded
+string.
+
+=back
+
+=head1 Digest speed
+
+This table should give some indication on the relative speed of
+different algorithms. It is sorted by throughput based on a benchmark
+done with of some implementations of this API:
+
+ Algorithm Size Implementation MB/s
+
+ MD4 128 Digest::MD4 v1.3 165.0
+ MD5 128 Digest::MD5 v2.33 98.8
+ SHA-256 256 Digest::SHA2 v1.1.0 66.7
+ SHA-1 160 Digest::SHA v4.3.1 58.9
+ SHA-1 160 Digest::SHA1 v2.10 48.8
+ SHA-256 256 Digest::SHA v4.3.1 41.3
+ Haval-256 256 Digest::Haval256 v1.0.4 39.8
+ SHA-384 384 Digest::SHA2 v1.1.0 19.6
+ SHA-512 512 Digest::SHA2 v1.1.0 19.3
+ SHA-384 384 Digest::SHA v4.3.1 19.2
+ SHA-512 512 Digest::SHA v4.3.1 19.2
+ Whirlpool 512 Digest::Whirlpool v1.0.2 13.0
+ MD2 128 Digest::MD2 v2.03 9.5
+
+ Adler-32 32 Digest::Adler32 v0.03 1.3
+ CRC-16 16 Digest::CRC v0.05 1.1
+ CRC-32 32 Digest::CRC v0.05 1.1
+ MD5 128 Digest::Perl::MD5 v1.5 1.0
+ CRC-CCITT 16 Digest::CRC v0.05 0.8
+
+These numbers was achieved Apr 2004 with ActivePerl-5.8.3 running
+under Linux on a P4 2.8 GHz CPU. The last 5 entries differ by being
+pure perl implementations of the algorithms, which explains why they
+are so slow.
+
+=head1 SEE ALSO
+
+L<Digest::Adler32>, L<Digest::CRC>, L<Digest::Haval256>,
+L<Digest::HMAC>, L<Digest::MD2>, L<Digest::MD4>, L<Digest::MD5>,
+L<Digest::SHA>, L<Digest::SHA1>, L<Digest::SHA2>, L<Digest::Whirlpool>
+
+New digest implementations should consider subclassing from L<Digest::base>.
+
+L<MIME::Base64>
+
+http://en.wikipedia.org/wiki/Cryptographic_hash_function
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+The C<Digest::> interface is based on the interface originally
+developed by Neil Winton for his C<MD5> module.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+ Copyright 1998-2006 Gisle Aas.
+ Copyright 1995,1996 Neil Winton.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/DirHandle.pm b/Master/tlpkg/tlperl/lib/DirHandle.pm
new file mode 100644
index 00000000000..fc27dfb1e63
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DirHandle.pm
@@ -0,0 +1,92 @@
+package DirHandle;
+
+our $VERSION = '1.03';
+
+=head1 NAME
+
+DirHandle - supply object methods for directory handles
+
+=head1 SYNOPSIS
+
+ use DirHandle;
+ $d = DirHandle->new(".");
+ if (defined $d) {
+ while (defined($_ = $d->read)) { something($_); }
+ $d->rewind;
+ while (defined($_ = $d->read)) { something_else($_); }
+ undef $d;
+ }
+
+=head1 DESCRIPTION
+
+The C<DirHandle> method provide an alternative interface to the
+opendir(), closedir(), readdir(), and rewinddir() functions.
+
+The only objective benefit to using C<DirHandle> is that it avoids
+namespace pollution by creating globs to hold directory handles.
+
+=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.
+
+=back
+
+=cut
+
+require 5.000;
+use Carp;
+use Symbol;
+
+sub new {
+ @_ >= 1 && @_ <= 2 or croak 'usage: DirHandle->new( [DIRNAME] )';
+ my $class = shift;
+ my $dh = gensym;
+ if (@_) {
+ DirHandle::open($dh, $_[0])
+ or return undef;
+ }
+ bless $dh, $class;
+}
+
+sub DESTROY {
+ my ($dh) = @_;
+ # Don't warn about already being closed as it may have been closed
+ # correctly, or maybe never opened at all.
+ local($., $@, $!, $^E, $?);
+ no warnings 'io';
+ closedir($dh);
+}
+
+sub open {
+ @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
+ my ($dh, $dirname) = @_;
+ opendir($dh, $dirname);
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $dh->close()';
+ my ($dh) = @_;
+ closedir($dh);
+}
+
+sub read {
+ @_ == 1 or croak 'usage: $dh->read()';
+ my ($dh) = @_;
+ readdir($dh);
+}
+
+sub rewind {
+ @_ == 1 or croak 'usage: $dh->rewind()';
+ my ($dh) = @_;
+ rewinddir($dh);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Dumpvalue.pm b/Master/tlpkg/tlperl/lib/Dumpvalue.pm
new file mode 100644
index 00000000000..af16b1dd088
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Dumpvalue.pm
@@ -0,0 +1,648 @@
+use 5.006_001; # for (defined ref) and $#$v and our
+package Dumpvalue;
+use strict;
+our $VERSION = '1.13';
+our(%address, $stab, @stab, %stab, %subs);
+
+# documentation nits, handle complex data structures better by chromatic
+# translate control chars to ^X - Randal Schwartz
+# Modifications to print types by Peter Gordon v1.0
+
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+
+# Won't dump symbol tables and contents of debugged files by default
+
+# (IZ) changes for objectification:
+# c) quote() renamed to method set_quote();
+# d) unctrlSet() renamed to method set_unctrl();
+# f) Compiles with `use strict', but in two places no strict refs is needed:
+# maybe more problems are waiting...
+
+my %defaults = (
+ globPrint => 0,
+ printUndef => 1,
+ tick => "auto",
+ unctrl => 'quote',
+ subdump => 1,
+ dumpReused => 0,
+ bareStringify => 1,
+ hashDepth => '',
+ arrayDepth => '',
+ dumpDBFiles => '',
+ dumpPackages => '',
+ quoteHighBit => '',
+ usageOnly => '',
+ compactDump => '',
+ veryCompact => '',
+ stopDbSignal => '',
+ );
+
+sub new {
+ my $class = shift;
+ my %opt = (%defaults, @_);
+ bless \%opt, $class;
+}
+
+sub set {
+ my $self = shift;
+ my %opt = @_;
+ @$self{keys %opt} = values %opt;
+}
+
+sub get {
+ my $self = shift;
+ wantarray ? @$self{@_} : $$self{pop @_};
+}
+
+sub dumpValue {
+ my $self = shift;
+ die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
+ local %address;
+ local $^W=0;
+ (print "undef\n"), return unless defined $_[0];
+ (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
+ $self->unwrap($_[0],0);
+}
+
+sub dumpValues {
+ my $self = shift;
+ local %address;
+ local $^W=0;
+ (print "undef\n"), return unless defined $_[0];
+ $self->unwrap(\@_,0);
+}
+
+# This one is good for variable names:
+
+sub unctrl {
+ local($_) = @_;
+
+ return \$_ if ref \$_ eq "GLOB";
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ $_;
+}
+
+sub stringify {
+ my $self = shift;
+ local $_ = shift;
+ my $noticks = shift;
+ my $tick = $self->{tick};
+
+ return 'undef' unless defined $_ or not $self->{printUndef};
+ return $_ . "" if ref \$_ eq 'GLOB';
+ { no strict 'refs';
+ $_ = &{'overload::StrVal'}($_)
+ if $self->{bareStringify} and ref $_
+ and %overload:: and defined &{'overload::StrVal'};
+ }
+
+ if ($tick eq 'auto') {
+ if (/[\000-\011\013-\037\177]/) {
+ $tick = '"';
+ } else {
+ $tick = "'";
+ }
+ }
+ if ($tick eq "'") {
+ s/([\'\\])/\\$1/g;
+ } elsif ($self->{unctrl} eq 'unctrl') {
+ s/([\"\\])/\\$1/g ;
+ s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
+ if $self->{quoteHighBit};
+ } elsif ($self->{unctrl} eq 'quote') {
+ s/([\"\\\$\@])/\\$1/g if $tick eq '"';
+ s/\033/\\e/g;
+ s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
+ }
+ s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
+ ($noticks || /^\d+(\.\d*)?\Z/)
+ ? $_
+ : $tick . $_ . $tick;
+}
+
+sub DumpElem {
+ my ($self, $v) = (shift, shift);
+ my $short = $self->stringify($v, ref $v);
+ my $shortmore = '';
+ if ($self->{veryCompact} && ref $v
+ && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
+ my $depth = $#$v;
+ ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
+ if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
+ my @a = map $self->stringify($_), @$v[0..$depth];
+ print "0..$#{$v} @a$shortmore\n";
+ } elsif ($self->{veryCompact} && ref $v
+ && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
+ my @a = sort keys %$v;
+ my $depth = $#a;
+ ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
+ if $self->{hashDepth} and $depth >= $self->{hashDepth};
+ my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
+ @a[0..$depth];
+ local $" = ', ';
+ print "@b$shortmore\n";
+ } else {
+ print "$short\n";
+ $self->unwrap($v,shift);
+ }
+}
+
+sub unwrap {
+ my $self = shift;
+ return if $DB::signal and $self->{stopDbSignal};
+ my ($v) = shift ;
+ my ($s) = shift ; # extra no of spaces
+ my $sp;
+ my (%v,@v,$address,$short,$fileno);
+
+ $sp = " " x $s ;
+ $s += 3 ;
+
+ # Check for reused addresses
+ if (ref $v) {
+ my $val = $v;
+ { no strict 'refs';
+ $val = &{'overload::StrVal'}($v)
+ if %overload:: and defined &{'overload::StrVal'};
+ }
+ ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
+ if (!$self->{dumpReused} && defined $address) {
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}-> REUSED_ADDRESS\n" ;
+ return ;
+ }
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ $address = "$v" . ""; # To avoid a bug with globs
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}*DUMPED_GLOB*\n" ;
+ return ;
+ }
+ }
+
+ if (ref $v eq 'Regexp') {
+ my $re = "$v";
+ $re =~ s,/,\\/,g;
+ print "$sp-> qr/$re/\n";
+ return;
+ }
+
+ if ( UNIVERSAL::isa($v, 'HASH') ) {
+ my @sortKeys = sort keys(%$v) ;
+ my $more;
+ my $tHashDepth = $#sortKeys ;
+ $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
+ unless $self->{hashDepth} eq '' ;
+ $more = "....\n" if $tHashDepth < $#sortKeys ;
+ my $shortmore = "";
+ $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
+ $#sortKeys = $tHashDepth ;
+ if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
+ $short = $sp;
+ my @keys;
+ for (@sortKeys) {
+ push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
+ }
+ $short .= join ', ', @keys;
+ $short .= $shortmore;
+ (print "$short\n"), return if length $short <= $self->{compactDump};
+ }
+ for my $key (@sortKeys) {
+ return if $DB::signal and $self->{stopDbSignal};
+ my $value = $ {$v}{$key} ;
+ print $sp, $self->stringify($key), " => ";
+ $self->DumpElem($value, $s);
+ }
+ print "$sp empty hash\n" unless @sortKeys;
+ print "$sp$more" if defined $more ;
+ } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
+ my $tArrayDepth = $#{$v} ;
+ my $more ;
+ $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
+ unless $self->{arrayDepth} eq '' ;
+ $more = "....\n" if $tArrayDepth < $#{$v} ;
+ my $shortmore = "";
+ $shortmore = " ..." if $tArrayDepth < $#{$v} ;
+ if ($self->{compactDump} && !grep(ref $_, @{$v})) {
+ if ($#$v >= 0) {
+ $short = $sp . "0..$#{$v} " .
+ join(" ",
+ map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
+ ) . "$shortmore";
+ } else {
+ $short = $sp . "empty array";
+ }
+ (print "$short\n"), return if length $short <= $self->{compactDump};
+ }
+ for my $num ($[ .. $tArrayDepth) {
+ return if $DB::signal and $self->{stopDbSignal};
+ print "$sp$num ";
+ if (exists $v->[$num]) {
+ $self->DumpElem($v->[$num], $s);
+ } else {
+ print "empty slot\n";
+ }
+ }
+ print "$sp empty array\n" unless @$v;
+ print "$sp$more" if defined $more ;
+ } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
+ print "$sp-> ";
+ $self->DumpElem($$v, $s);
+ } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
+ print "$sp-> ";
+ $self->dumpsub(0, $v);
+ } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
+ print "$sp-> ",$self->stringify($$v,1),"\n";
+ if ($self->{globPrint}) {
+ $s += 3;
+ $self->dumpglob('', $s, "{$$v}", $$v, 1);
+ } elsif (defined ($fileno = fileno($v))) {
+ print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ if ($self->{globPrint}) {
+ $self->dumpglob('', $s, "{$v}", $v, 1);
+ } elsif (defined ($fileno = fileno(\$v))) {
+ print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
+ }
+ }
+}
+
+sub matchvar {
+ $_[0] eq $_[1] or
+ ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
+ ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
+}
+
+sub compactDump {
+ my $self = shift;
+ $self->{compactDump} = shift if @_;
+ $self->{compactDump} = 6*80-1
+ if $self->{compactDump} and $self->{compactDump} < 2;
+ $self->{compactDump};
+}
+
+sub veryCompact {
+ my $self = shift;
+ $self->{veryCompact} = shift if @_;
+ $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
+ $self->{veryCompact};
+}
+
+sub set_unctrl {
+ my $self = shift;
+ if (@_) {
+ my $in = shift;
+ if ($in eq 'unctrl' or $in eq 'quote') {
+ $self->{unctrl} = $in;
+ } else {
+ print "Unknown value for `unctrl'.\n";
+ }
+ }
+ $self->{unctrl};
+}
+
+sub set_quote {
+ my $self = shift;
+ if (@_ and $_[0] eq '"') {
+ $self->{tick} = '"';
+ $self->{unctrl} = 'quote';
+ } elsif (@_ and $_[0] eq 'auto') {
+ $self->{tick} = 'auto';
+ $self->{unctrl} = 'quote';
+ } elsif (@_) { # Need to set
+ $self->{tick} = "'";
+ $self->{unctrl} = 'unctrl';
+ }
+ $self->{tick};
+}
+
+sub dumpglob {
+ my $self = shift;
+ return if $DB::signal and $self->{stopDbSignal};
+ my ($package, $off, $key, $val, $all) = @_;
+ local(*stab) = $val;
+ my $fileno;
+ if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
+ print( (' ' x $off) . "\$", &unctrl($key), " = " );
+ $self->DumpElem($stab, 3+$off);
+ }
+ if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
+ print( (' ' x $off) . "\@$key = (\n" );
+ $self->unwrap(\@stab,3+$off) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if ($key ne "main::" && $key ne "DB::" && %stab
+ && ($self->{dumpPackages} or $key !~ /::$/)
+ && ($key !~ /^_</ or $self->{dumpDBFiles})
+ && !($package eq "Dumpvalue" and $key eq "stab")) {
+ print( (' ' x $off) . "\%$key = (\n" );
+ $self->unwrap(\%stab,3+$off) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if (defined ($fileno = fileno(*stab))) {
+ print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
+ }
+ if ($all) {
+ if (defined &stab) {
+ $self->dumpsub($off, $key);
+ }
+ }
+}
+
+sub CvGV_name {
+ my $self = shift;
+ my $in = shift;
+ return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
+ $in = \&$in; # Hard reference...
+ eval {require Devel::Peek; 1} or return;
+ my $gv = Devel::Peek::CvGV($in) or return;
+ *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
+sub dumpsub {
+ my $self = shift;
+ my ($off,$sub) = @_;
+ my $ini = $sub;
+ my $s;
+ $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
+ my $subref = defined $1 ? \&$sub : \&$ini;
+ my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+ || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
+ || ($self->{subdump} && ($s = $self->findsubs("$subref"))
+ && $DB::sub{$s});
+ $s = $sub unless defined $s;
+ $place = '???' unless defined $place;
+ print( (' ' x $off) . "&$s in $place\n" );
+}
+
+sub findsubs {
+ my $self = shift;
+ return undef unless %DB::sub;
+ my ($addr, $name, $loc);
+ while (($name, $loc) = each %DB::sub) {
+ $addr = \&$name;
+ $subs{"$addr"} = $name;
+ }
+ $self->{subdump} = 0;
+ $subs{ shift() };
+}
+
+sub dumpvars {
+ my $self = shift;
+ my ($package,@vars) = @_;
+ local(%address,$^W);
+ my ($key,$val);
+ $package .= "::" unless $package =~ /::$/;
+ *stab = *main::;
+
+ while ($package =~ /(\w+?::)/g) {
+ *stab = $ {stab}{$1};
+ }
+ $self->{TotalStrings} = 0;
+ $self->{Strings} = 0;
+ $self->{CompleteTotal} = 0;
+ while (($key,$val) = each(%stab)) {
+ return if $DB::signal and $self->{stopDbSignal};
+ next if @vars && !grep( matchvar($key, $_), @vars );
+ if ($self->{usageOnly}) {
+ $self->globUsage(\$val, $key)
+ if ($package ne 'Dumpvalue' or $key ne 'stab')
+ and ref(\$val) eq 'GLOB';
+ } else {
+ $self->dumpglob($package, 0,$key, $val);
+ }
+ }
+ if ($self->{usageOnly}) {
+ print <<EOP;
+String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
+EOP
+ $self->{CompleteTotal} += $self->{TotalStrings};
+ print <<EOP;
+Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
+EOP
+ }
+}
+
+sub scalarUsage {
+ my $self = shift;
+ my $size;
+ if (UNIVERSAL::isa($_[0], 'ARRAY')) {
+ $size = $self->arrayUsage($_[0]);
+ } elsif (UNIVERSAL::isa($_[0], 'HASH')) {
+ $size = $self->hashUsage($_[0]);
+ } elsif (!ref($_[0])) {
+ $size = length($_[0]);
+ }
+ $self->{TotalStrings} += $size;
+ $self->{Strings}++;
+ $size;
+}
+
+sub arrayUsage { # array ref, name
+ my $self = shift;
+ my $size = 0;
+ map {$size += $self->scalarUsage($_)} @{$_[0]};
+ my $len = @{$_[0]};
+ print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
+ if defined $_[1];
+ $self->{CompleteTotal} += $size;
+ $size;
+}
+
+sub hashUsage { # hash ref, name
+ my $self = shift;
+ my @keys = keys %{$_[0]};
+ my @values = values %{$_[0]};
+ my $keys = $self->arrayUsage(\@keys);
+ my $values = $self->arrayUsage(\@values);
+ my $len = @keys;
+ my $total = $keys + $values;
+ print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
+ " (keys: $keys; values: $values; total: $total bytes)\n"
+ if defined $_[1];
+ $total;
+}
+
+sub globUsage { # glob ref, name
+ my $self = shift;
+ local *stab = *{$_[0]};
+ my $total = 0;
+ $total += $self->scalarUsage($stab) if defined $stab;
+ $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
+ $total += $self->hashUsage(\%stab, $_[1])
+ if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
+ #and !($package eq "Dumpvalue" and $key eq "stab"));
+ $total;
+}
+
+1;
+
+=head1 NAME
+
+Dumpvalue - provides screen dump of Perl data.
+
+=head1 SYNOPSIS
+
+ use Dumpvalue;
+ my $dumper = Dumpvalue->new;
+ $dumper->set(globPrint => 1);
+ $dumper->dumpValue(\*::);
+ $dumper->dumpvars('main');
+ my $dump = $dumper->stringify($some_value);
+
+=head1 DESCRIPTION
+
+=head2 Creation
+
+A new dumper is created by a call
+
+ $d = Dumpvalue->new(option1 => value1, option2 => value2)
+
+Recognized options:
+
+=over 4
+
+=item C<arrayDepth>, C<hashDepth>
+
+Print only first N elements of arrays and hashes. If false, prints all the
+elements.
+
+=item C<compactDump>, C<veryCompact>
+
+Change style of array and hash dump. If true, short array
+may be printed on one line.
+
+=item C<globPrint>
+
+Whether to print contents of globs.
+
+=item C<dumpDBFiles>
+
+Dump arrays holding contents of debugged files.
+
+=item C<dumpPackages>
+
+Dump symbol tables of packages.
+
+=item C<dumpReused>
+
+Dump contents of "reused" addresses.
+
+=item C<tick>, C<quoteHighBit>, C<printUndef>
+
+Change style of string dump. Default value of C<tick> is C<auto>, one
+can enable either double-quotish dump, or single-quotish by setting it
+to C<"> or C<'>. By default, characters with high bit set are printed
+I<as is>. If C<quoteHighBit> is set, they will be quoted.
+
+=item C<usageOnly>
+
+rudimentally per-package memory usage dump. If set,
+C<dumpvars> calculates total size of strings in variables in the package.
+
+=item unctrl
+
+Changes the style of printout of strings. Possible values are
+C<unctrl> and C<quote>.
+
+=item subdump
+
+Whether to try to find the subroutine name given the reference.
+
+=item bareStringify
+
+Whether to write the non-overloaded form of the stringify-overloaded objects.
+
+=item quoteHighBit
+
+Whether to print chars with high bit set in binary or "as is".
+
+=item stopDbSignal
+
+Whether to abort printing if debugger signal flag is raised.
+
+=back
+
+Later in the life of the object the methods may be queries with get()
+method and set() method (which accept multiple arguments).
+
+=head2 Methods
+
+=over 4
+
+=item dumpValue
+
+ $dumper->dumpValue($value);
+ $dumper->dumpValue([$value1, $value2]);
+
+Prints a dump to the currently selected filehandle.
+
+=item dumpValues
+
+ $dumper->dumpValues($value1, $value2);
+
+Same as C<< $dumper->dumpValue([$value1, $value2]); >>.
+
+=item stringify
+
+ my $dump = $dumper->stringify($value [,$noticks] );
+
+Returns the dump of a single scalar without printing. If the second
+argument is true, the return value does not contain enclosing ticks.
+Does not handle data structures.
+
+=item dumpvars
+
+ $dumper->dumpvars('my_package');
+ $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
+
+The optional arguments are considered as literal strings unless they
+start with C<~> or C<!>, in which case they are interpreted as regular
+expressions (possibly negated).
+
+The second example prints entries with names C<foo>, and also entries
+with names which ends on C<bar>, or are shorter than 5 chars.
+
+=item set_quote
+
+ $d->set_quote('"');
+
+Sets C<tick> and C<unctrl> options to suitable values for printout with the
+given quote char. Possible values are C<auto>, C<'> and C<">.
+
+=item set_unctrl
+
+ $d->set_unctrl('unctrl');
+
+Sets C<unctrl> option with checking for an invalid argument.
+Possible values are C<unctrl> and C<quote>.
+
+=item compactDump
+
+ $d->compactDump(1);
+
+Sets C<compactDump> option. If the value is 1, sets to a reasonable
+big number.
+
+=item veryCompact
+
+ $d->veryCompact(1);
+
+Sets C<compactDump> and C<veryCompact> options simultaneously.
+
+=item set
+
+ $d->set(option1 => value1, option2 => value2);
+
+=item get
+
+ @values = $d->get('option1', 'option2');
+
+=back
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/DynaLoader.pm b/Master/tlpkg/tlperl/lib/DynaLoader.pm
new file mode 100644
index 00000000000..8ffc9b7672c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/DynaLoader.pm
@@ -0,0 +1,771 @@
+
+# Generated from DynaLoader_pm.PL
+
+package DynaLoader;
+
+# And Gandalf said: 'Many folk like to know beforehand what is to
+# be set on the table; but those who have laboured to prepare the
+# feast like to keep their secret; for wonder makes the words of
+# praise louder.'
+
+# (Quote from Tolkien suggested by Anno Siegel.)
+#
+# See pod text at end of file for documentation.
+# See also ext/DynaLoader/README in source tree for other information.
+#
+# Tim.Bunce@ig.co.uk, August 1994
+
+BEGIN {
+ $VERSION = '1.10';
+}
+
+require AutoLoader;
+*AUTOLOAD = \&AutoLoader::AUTOLOAD;
+
+use Config;
+
+# enable debug/trace messages from DynaLoader perl code
+$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+#
+# Flags to alter dl_load_file behaviour. Assigned bits:
+# 0x01 make symbols available for linking later dl_load_file's.
+# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+# (ignored under VMS; effect is built-in to image linking)
+#
+# This is called as a class method $module->dl_load_flags. The
+# definition here will be inherited and result on "default" loading
+# behaviour unless a sub-class of DynaLoader defines its own version.
+#
+
+sub dl_load_flags { 0x00 }
+
+($dl_dlext, $dl_so, $dlsrc) = @Config::Config{qw(dlext so dlsrc)};
+
+
+$do_expand = 0;
+
+
+
+@dl_require_symbols = (); # names of symbols we need
+@dl_resolve_using = (); # names of files to link with
+@dl_library_path = (); # path to look for files
+
+#XSLoader.pm may have added elements before we were required
+#@dl_shared_objects = (); # shared objects for symbols we have
+#@dl_librefs = (); # things we have loaded
+#@dl_modules = (); # Modules we have loaded
+
+# This is a fix to support DLD's unfortunate desire to relink -lc
+@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
+
+# Initialise @dl_library_path with the 'standard' library path
+# for this platform as determined by Configure.
+
+push(@dl_library_path, split(' ', $Config::Config{libpth}));
+
+
+my $ldlibpthname = $Config::Config{ldlibpthname};
+my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
+my $pthsep = $Config::Config{path_sep};
+
+# Add to @dl_library_path any extra directories we can gather from environment
+# during runtime.
+
+if ($ldlibpthname_defined &&
+ exists $ENV{$ldlibpthname}) {
+ push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
+}
+
+# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
+
+if ($ldlibpthname_defined &&
+ $ldlibpthname ne 'LD_LIBRARY_PATH' &&
+ exists $ENV{LD_LIBRARY_PATH}) {
+ push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
+}
+
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_error);
+
+if ($dl_debug) {
+ print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
+ print STDERR "DynaLoader not linked into this perl\n"
+ unless defined(&boot_DynaLoader);
+}
+
+1; # End of main code
+
+
+sub croak { require Carp; Carp::croak(@_) }
+
+sub bootstrap_inherit {
+ my $module = $_[0];
+ local *isa = *{"$module\::ISA"};
+ local @isa = (@isa, 'DynaLoader');
+ # Cannot goto due to delocalization. Will report errors on a wrong line?
+ bootstrap(@_);
+}
+
+# The bootstrap function cannot be autoloaded (without complications)
+# so we define it here:
+
+sub bootstrap {
+ # use local vars to enable $module.bs script to edit values
+ local(@args) = @_;
+ local($module) = $args[0];
+ local(@dirs, $file);
+
+ unless ($module) {
+ require Carp;
+ Carp::confess("Usage: DynaLoader::bootstrap(module)");
+ }
+
+ # A common error on platforms which don't support dynamic loading.
+ # Since it's fatal and potentially confusing we give a detailed message.
+ croak("Can't load module $module, dynamic loading not available in this perl.\n".
+ " (You may need to build a new perl executable which either supports\n".
+ " dynamic loading or has the $module module statically linked into it.)\n")
+ unless defined(&dl_load_file);
+
+
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+ # Some systems have restrictions on files names for DLL's etc.
+ # mod2fname returns appropriate file base name (typically truncated)
+ # It may also edit @modparts if required.
+ $modfname = &mod2fname(\@modparts) if defined &mod2fname;
+
+
+
+ my $modpname = join('/',@modparts);
+
+ print STDERR "DynaLoader::bootstrap for $module ",
+ "(auto/$modpname/$modfname.$dl_dlext)\n"
+ if $dl_debug;
+
+ foreach (@INC) {
+
+
+ my $dir = "$_/auto/$modpname";
+
+
+ next unless -d $dir; # skip over uninteresting directories
+
+ # check for common cases to avoid autoload of dl_findfile
+ my $try = "$dir/$modfname.$dl_dlext";
+ last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try);
+
+ # no luck here, save dir for possible later dl_findfile search
+ push @dirs, $dir;
+ }
+ # last resort, let dl_findfile have a go in all known locations
+ $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
+
+ croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
+ unless $file; # wording similar to error from 'require'
+
+
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @dl_require_symbols = ($bootname);
+
+ # Execute optional '.bootstrap' perl script for this module.
+ # The .bs file can be used to configure @dl_resolve_using etc to
+ # match the needs of the individual module on this architecture.
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
+ if (-s $bs) { # only read file if it's not empty
+ print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
+ eval { do $bs; };
+ warn "$bs: $@\n" if $@;
+ }
+
+ my $boot_symbol_ref;
+
+
+
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, $module->dl_load_flags) or
+ croak("Can't load '$file' for module $module: ".dl_error());
+
+ push(@dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
+ croak("Can't find '$bootname' symbol in $file\n");
+
+ push(@dl_modules, $module); # record loaded module
+
+ boot:
+ my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
+
+ # See comment block above
+
+ push(@dl_shared_objects, $file); # record files loaded
+
+ &$xs(@args);
+}
+
+
+#sub _check_file { # private utility to handle dl_expandspec vs -f tests
+# my($file) = @_;
+# return $file if (!$do_expand && -f $file); # the common case
+# return $file if ( $do_expand && ($file=dl_expandspec($file)));
+# return undef;
+#}
+
+
+# Let autosplit and the autoloader deal with these functions:
+__END__
+
+
+sub dl_findfile {
+ # Read ext/DynaLoader/DynaLoader.doc for detailed information.
+ # This function does not automatically consider the architecture
+ # or the perl library auto directories.
+ my (@args) = @_;
+ my (@dirs, $dir); # which directories to search
+ my (@found); # full paths to real files we have found
+ #my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions
+ #my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries
+
+ print STDERR "dl_findfile(@args)\n" if $dl_debug;
+
+ # accumulate directories but process files as they appear
+ arg: foreach(@args) {
+ # Special fast case: full filepath requires no search
+
+
+
+ if (m:/: && -f $_) {
+ push(@found,$_);
+ last arg unless wantarray;
+ next;
+ }
+
+
+ # Deal with directories first:
+ # Using a -L prefix is the preferred option (faster and more robust)
+ if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
+
+
+
+ # Otherwise we try to try to spot directories by a heuristic
+ # (this is a more complicated issue than it first appears)
+ if (m:/: && -d $_) { push(@dirs, $_); next; }
+
+
+
+ # Only files should get this far...
+ my(@names, $name); # what filenames to look for
+ if (m:-l: ) { # convert -lname to appropriate library name
+ s/-l//;
+ push(@names,"lib$_.$dl_so");
+ push(@names,"lib$_.a");
+ } else { # Umm, a bare name. Try various alternatives:
+ # these should be ordered with the most likely first
+ push(@names,"$_.$dl_dlext") unless m/\.$dl_dlext$/o;
+ push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
+ push(@names,"lib$_.$dl_so") unless m:/:;
+ push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
+ push(@names, $_);
+ }
+ my $dirsep = '/';
+
+ foreach $dir (@dirs, @dl_library_path) {
+ next unless -d $dir;
+
+ foreach $name (@names) {
+ my($file) = "$dir$dirsep$name";
+ print STDERR " checking in $dir for $name\n" if $dl_debug;
+ $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
+ #$file = _check_file($file);
+ if ($file) {
+ push(@found, $file);
+ next arg; # no need to look any further
+ }
+ }
+ }
+ }
+ if ($dl_debug) {
+ foreach(@dirs) {
+ print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
+ }
+ print STDERR "dl_findfile found: @found\n";
+ }
+ return $found[0] unless wantarray;
+ @found;
+}
+
+
+sub dl_expandspec {
+ my($spec) = @_;
+ # Optional function invoked if DynaLoader.pm sets $do_expand.
+ # Most systems do not require or use this function.
+ # Some systems may implement it in the dl_*.xs file in which case
+ # this autoload version will not be called but is harmless.
+
+ # This function is designed to deal with systems which treat some
+ # 'filenames' in a special way. For example VMS 'Logical Names'
+ # (something like unix environment variables - but different).
+ # This function should recognise such names and expand them into
+ # full file paths.
+ # Must return undef if $spec is invalid or file does not exist.
+
+ my $file = $spec; # default output to input
+
+
+ return undef unless -f $file;
+
+ print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
+ $file;
+}
+
+sub dl_find_symbol_anywhere
+{
+ my $sym = shift;
+ my $libref;
+ foreach $libref (@dl_librefs) {
+ my $symref = dl_find_symbol($libref,$sym);
+ return $symref if $symref;
+ }
+ return undef;
+}
+
+=head1 NAME
+
+DynaLoader - Dynamically load C libraries into Perl code
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ require DynaLoader;
+ @ISA = qw(... DynaLoader ...);
+ bootstrap YourPackage;
+
+ # optional method for 'global' loading
+ sub dl_load_flags { 0x01 }
+
+
+=head1 DESCRIPTION
+
+This document defines a standard generic interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement automatic dynamic loading of Perl modules.
+
+This document serves as both a specification for anyone wishing to
+implement the DynaLoader for a new platform and as a guide for
+anyone wishing to use the DynaLoader directly in an application.
+
+The DynaLoader is designed to be a very simple high-level
+interface that is sufficiently general to cover the requirements
+of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.
+
+It is also hoped that the interface will cover the needs of OS/2, NT
+etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).
+
+It must be stressed that the DynaLoader, by itself, is practically
+useless for accessing non-Perl libraries because it provides almost no
+Perl-to-C 'glue'. There is, for example, no mechanism for calling a C
+library function or supplying arguments. A C::DynaLib module
+is available from CPAN sites which performs that function for some
+common system types. And since the year 2000, there's also Inline::C,
+a module that allows you to write Perl subroutines in C. Also available
+from your local CPAN site.
+
+DynaLoader Interface Summary
+
+ @dl_library_path
+ @dl_resolve_using
+ @dl_require_symbols
+ $dl_debug
+ @dl_librefs
+ @dl_modules
+ @dl_shared_objects
+ Implemented in:
+ bootstrap($modulename) Perl
+ @filepaths = dl_findfile(@names) Perl
+ $flags = $modulename->dl_load_flags Perl
+ $symref = dl_find_symbol_anywhere($symbol) Perl
+
+ $libref = dl_load_file($filename, $flags) C
+ $status = dl_unload_file($libref) C
+ $symref = dl_find_symbol($libref, $symbol) C
+ @symbols = dl_undef_symbols() C
+ dl_install_xsub($name, $symref [, $filename]) C
+ $message = dl_error C
+
+=over 4
+
+=item @dl_library_path
+
+The standard/default list of directories in which dl_findfile() will
+search for libraries etc. Directories are searched in order:
+$dl_library_path[0], [1], ... etc
+
+@dl_library_path is initialised to hold the list of 'normal' directories
+(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
+ensure portability across a wide range of platforms.
+
+@dl_library_path should also be initialised with any other directories
+that can be determined from the environment at runtime (such as
+LD_LIBRARY_PATH for SunOS).
+
+After initialisation @dl_library_path can be manipulated by an
+application using push and unshift before calling dl_findfile().
+Unshift can be used to add directories to the front of the search order
+either to save search time or to override libraries with the same name
+in the 'normal' directories.
+
+The load function that dl_load_file() calls may require an absolute
+pathname. The dl_findfile() function and @dl_library_path can be
+used to search for and return the absolute pathname for the
+library/object that you wish to load.
+
+=item @dl_resolve_using
+
+A list of additional libraries or other shared objects which can be
+used to resolve any undefined symbols that might be generated by a
+later call to load_file().
+
+This is only required on some platforms which do not handle dependent
+libraries automatically. For example the Socket Perl extension
+library (F<auto/Socket/Socket.so>) contains references to many socket
+functions which need to be resolved when it's loaded. Most platforms
+will automatically know where to find the 'dependent' library (e.g.,
+F</usr/lib/libsocket.so>). A few platforms need to be told the
+location of the dependent library explicitly. Use @dl_resolve_using
+for this.
+
+Example usage:
+
+ @dl_resolve_using = dl_findfile('-lsocket');
+
+=item @dl_require_symbols
+
+A list of one or more symbol names that are in the library/object file
+to be dynamically loaded. This is only required on some platforms.
+
+=item @dl_librefs
+
+An array of the handles returned by successful calls to dl_load_file(),
+made by bootstrap, in the order in which they were loaded.
+Can be used with dl_find_symbol() to look for a symbol in any of
+the loaded files.
+
+=item @dl_modules
+
+An array of module (package) names that have been bootstrap'ed.
+
+=item @dl_shared_objects
+
+An array of file names for the shared objects that were loaded.
+
+=item dl_error()
+
+Syntax:
+
+ $message = dl_error();
+
+Error message text from the last failed DynaLoader function. Note
+that, similar to errno in unix, a successful function call does not
+reset this message.
+
+Implementations should detect the error as soon as it occurs in any of
+the other functions and save the corresponding message for later
+retrieval. This will avoid problems on some platforms (such as SunOS)
+where the error message is very temporary (e.g., dlerror()).
+
+=item $dl_debug
+
+Internal debugging messages are enabled when $dl_debug is set true.
+Currently setting $dl_debug only affects the Perl side of the
+DynaLoader. These messages should help an application developer to
+resolve any DynaLoader usage problems.
+
+$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.
+
+For the DynaLoader developer/porter there is a similar debugging
+variable added to the C code (see dlutils.c) and enabled if Perl was
+built with the B<-DDEBUGGING> flag. This can also be set via the
+PERL_DL_DEBUG environment variable. Set to 1 for minimal information or
+higher for more.
+
+=item dl_findfile()
+
+Syntax:
+
+ @filepaths = dl_findfile(@names)
+
+Determine the full paths (including file suffix) of one or more
+loadable files given their generic names and optionally one or more
+directories. Searches directories in @dl_library_path by default and
+returns an empty list if no files were found.
+
+Names can be specified in a variety of platform independent forms. Any
+names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
+an appropriate suffix for the platform.
+
+If a name does not already have a suitable prefix and/or suffix then
+the corresponding file will be searched for by trying combinations of
+prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
+and "$name".
+
+If any directories are included in @names they are searched before
+@dl_library_path. Directories may be specified as B<-Ldir>. Any other
+names are treated as filenames to be searched for.
+
+Using arguments of the form C<-Ldir> and C<-lname> is recommended.
+
+Example:
+
+ @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));
+
+
+=item dl_expandspec()
+
+Syntax:
+
+ $filepath = dl_expandspec($spec)
+
+Some unusual systems, such as VMS, require special filename handling in
+order to deal with symbolic names for files (i.e., VMS's Logical Names).
+
+To support these systems a dl_expandspec() function can be implemented
+either in the F<dl_*.xs> file or code can be added to the autoloadable
+dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for
+more information.
+
+=item dl_load_file()
+
+Syntax:
+
+ $libref = dl_load_file($filename, $flags)
+
+Dynamically load $filename, which must be the path to a shared object
+or library. An opaque 'library reference' is returned as a handle for
+the loaded object. Returns undef on error.
+
+The $flags argument to alters dl_load_file behaviour.
+Assigned bits:
+
+ 0x01 make symbols available for linking later dl_load_file's.
+ (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+ (ignored under VMS; this is a normal part of image linking)
+
+(On systems that provide a handle for the loaded object such as SunOS
+and HPUX, $libref will be that handle. On other systems $libref will
+typically be $filename or a pointer to a buffer containing $filename.
+The application should not examine or alter $libref in any way.)
+
+This is the function that does the real work. It should use the
+current values of @dl_require_symbols and @dl_resolve_using if required.
+
+ SunOS: dlopen($filename)
+ HP-UX: shl_load($filename)
+ Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
+ NeXT: rld_load($filename, @dl_resolve_using)
+ VMS: lib$find_image_symbol($filename,$dl_require_symbols[0])
+
+(The dlopen() function is also used by Solaris and some versions of
+Linux, and is a common choice when providing a "wrapper" on other
+mechanisms as is done in the OS/2 port.)
+
+=item dl_unload_file()
+
+Syntax:
+
+ $status = dl_unload_file($libref)
+
+Dynamically unload $libref, which must be an opaque 'library reference' as
+returned from dl_load_file. Returns one on success and zero on failure.
+
+This function is optional and may not necessarily be provided on all platforms.
+If it is defined, it is called automatically when the interpreter exits for
+every shared object or library loaded by DynaLoader::bootstrap. All such
+library references are stored in @dl_librefs by DynaLoader::Bootstrap as it
+loads the libraries. The files are unloaded in last-in, first-out order.
+
+This unloading is usually necessary when embedding a shared-object perl (e.g.
+one configured with -Duseshrplib) within a larger application, and the perl
+interpreter is created and destroyed several times within the lifetime of the
+application. In this case it is possible that the system dynamic linker will
+unload and then subsequently reload the shared libperl without relocating any
+references to it from any files DynaLoaded by the previous incarnation of the
+interpreter. As a result, any shared objects opened by DynaLoader may point to
+a now invalid 'ghost' of the libperl shared object, causing apparently random
+memory corruption and crashes. This behaviour is most commonly seen when using
+Apache and mod_perl built with the APXS mechanism.
+
+ SunOS: dlclose($libref)
+ HP-UX: ???
+ Linux: ???
+ NeXT: ???
+ VMS: ???
+
+(The dlclose() function is also used by Solaris and some versions of
+Linux, and is a common choice when providing a "wrapper" on other
+mechanisms as is done in the OS/2 port.)
+
+=item dl_load_flags()
+
+Syntax:
+
+ $flags = dl_load_flags $modulename;
+
+Designed to be a method call, and to be overridden by a derived class
+(i.e. a class which has DynaLoader in its @ISA). The definition in
+DynaLoader itself returns 0, which produces standard behavior from
+dl_load_file().
+
+=item dl_find_symbol()
+
+Syntax:
+
+ $symref = dl_find_symbol($libref, $symbol)
+
+Return the address of the symbol $symbol or C<undef> if not found. If the
+target system has separate functions to search for symbols of different
+types then dl_find_symbol() should search for function symbols first and
+then other types.
+
+The exact manner in which the address is returned in $symref is not
+currently defined. The only initial requirement is that $symref can
+be passed to, and understood by, dl_install_xsub().
+
+ SunOS: dlsym($libref, $symbol)
+ HP-UX: shl_findsym($libref, $symbol)
+ Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
+ NeXT: rld_lookup("_$symbol")
+ VMS: lib$find_image_symbol($libref,$symbol)
+
+
+=item dl_find_symbol_anywhere()
+
+Syntax:
+
+ $symref = dl_find_symbol_anywhere($symbol)
+
+Applies dl_find_symbol() to the members of @dl_librefs and returns
+the first match found.
+
+=item dl_undef_symbols()
+
+Example
+
+ @symbols = dl_undef_symbols()
+
+Return a list of symbol names which remain undefined after load_file().
+Returns C<()> if not known. Don't worry if your platform does not provide
+a mechanism for this. Most do not need it and hence do not provide it,
+they just return an empty list.
+
+
+=item dl_install_xsub()
+
+Syntax:
+
+ dl_install_xsub($perl_name, $symref [, $filename])
+
+Create a new Perl external subroutine named $perl_name using $symref as
+a pointer to the function which implements the routine. This is simply
+a direct call to newXSUB(). Returns a reference to the installed
+function.
+
+The $filename parameter is used by Perl to identify the source file for
+the function if required by die(), caller() or the debugger. If
+$filename is not defined then "DynaLoader" will be used.
+
+
+=item bootstrap()
+
+Syntax:
+
+bootstrap($module)
+
+This is the normal entry point for automatic dynamic loading in Perl.
+
+It performs the following actions:
+
+=over 8
+
+=item *
+
+locates an auto/$module directory by searching @INC
+
+=item *
+
+uses dl_findfile() to determine the filename to load
+
+=item *
+
+sets @dl_require_symbols to C<("boot_$module")>
+
+=item *
+
+executes an F<auto/$module/$module.bs> file if it exists
+(typically used to add to @dl_resolve_using any files which
+are required to load the module on the current platform)
+
+=item *
+
+calls dl_load_flags() to determine how to load the file.
+
+=item *
+
+calls dl_load_file() to load the file
+
+=item *
+
+calls dl_undef_symbols() and warns if any symbols are undefined
+
+=item *
+
+calls dl_find_symbol() for "boot_$module"
+
+=item *
+
+calls dl_install_xsub() to install it as "${module}::bootstrap"
+
+=item *
+
+calls &{"${module}::bootstrap"} to bootstrap the module (actually
+it uses the function reference returned by dl_install_xsub for speed)
+
+=back
+
+=back
+
+
+=head1 AUTHOR
+
+Tim Bunce, 11 August 1994.
+
+This interface is based on the work and comments of (in no particular
+order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
+Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.
+
+Larry Wall designed the elegant inherited bootstrap mechanism and
+implemented the first Perl 5 dynamic loader using it.
+
+Solaris global loading added by Nick Ing-Simmons with design/coding
+assistance from Tim Bunce, January 1996.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Encode.pm b/Master/tlpkg/tlperl/lib/Encode.pm
new file mode 100644
index 00000000000..f1dff7820c2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Encode.pm
@@ -0,0 +1,963 @@
+#
+# $Id: Encode.pm,v 2.39 2009/11/26 09:23:48 dankogai Exp $
+#
+package Encode;
+use strict;
+use warnings;
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.39 $ =~ /(\d+)/g;
+sub DEBUG () { 0 }
+use XSLoader ();
+XSLoader::load( __PACKAGE__, $VERSION );
+
+require Exporter;
+use base qw/Exporter/;
+
+# Public, encouraged API is exported by default
+
+our @EXPORT = qw(
+ decode decode_utf8 encode encode_utf8 str2bytes bytes2str
+ encodings find_encoding clone_encoding
+);
+our @FB_FLAGS = qw(
+ DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC
+ PERLQQ HTMLCREF XMLCREF STOP_AT_PARTIAL
+);
+our @FB_CONSTS = qw(
+ FB_DEFAULT FB_CROAK FB_QUIET FB_WARN
+ FB_PERLQQ FB_HTMLCREF FB_XMLCREF
+);
+our @EXPORT_OK = (
+ qw(
+ _utf8_off _utf8_on define_encoding from_to is_16bit is_8bit
+ is_utf8 perlio_ok resolve_alias utf8_downgrade utf8_upgrade
+ ),
+ @FB_FLAGS, @FB_CONSTS,
+);
+
+our %EXPORT_TAGS = (
+ all => [ @EXPORT, @EXPORT_OK ],
+ default => [ @EXPORT ],
+ fallbacks => [ @FB_CONSTS ],
+ fallback_all => [ @FB_CONSTS, @FB_FLAGS ],
+);
+
+# Documentation moved after __END__ for speed - NI-S
+
+our $ON_EBCDIC = ( ord("A") == 193 );
+
+use Encode::Alias;
+
+# Make a %Encoding package variable to allow a certain amount of cheating
+our %Encoding;
+our %ExtModule;
+require Encode::Config;
+# See
+# https://bugzilla.redhat.com/show_bug.cgi?id=435505#c2
+# to find why sig handers inside eval{} are disabled.
+eval {
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ require Encode::ConfigLocal;
+};
+
+sub encodings {
+ my $class = shift;
+ my %enc;
+ if ( @_ and $_[0] eq ":all" ) {
+ %enc = ( %Encoding, %ExtModule );
+ }
+ else {
+ %enc = %Encoding;
+ for my $mod ( map { m/::/o ? $_ : "Encode::$_" } @_ ) {
+ DEBUG and warn $mod;
+ for my $enc ( keys %ExtModule ) {
+ $ExtModule{$enc} eq $mod and $enc{$enc} = $mod;
+ }
+ }
+ }
+ return sort { lc $a cmp lc $b }
+ grep { !/^(?:Internal|Unicode|Guess)$/o } keys %enc;
+}
+
+sub perlio_ok {
+ my $obj = ref( $_[0] ) ? $_[0] : find_encoding( $_[0] );
+ $obj->can("perlio_ok") and return $obj->perlio_ok();
+ return 0; # safety net
+}
+
+sub define_encoding {
+ my $obj = shift;
+ my $name = shift;
+ $Encoding{$name} = $obj;
+ my $lc = lc($name);
+ define_alias( $lc => $obj ) unless $lc eq $name;
+ while (@_) {
+ my $alias = shift;
+ define_alias( $alias, $obj );
+ }
+ return $obj;
+}
+
+sub getEncoding {
+ my ( $class, $name, $skip_external ) = @_;
+
+ ref($name) && $name->can('renew') and return $name;
+ exists $Encoding{$name} and return $Encoding{$name};
+ my $lc = lc $name;
+ exists $Encoding{$lc} and return $Encoding{$lc};
+
+ my $oc = $class->find_alias($name);
+ defined($oc) and return $oc;
+ $lc ne $name and $oc = $class->find_alias($lc);
+ defined($oc) and return $oc;
+
+ unless ($skip_external) {
+ if ( my $mod = $ExtModule{$name} || $ExtModule{$lc} ) {
+ $mod =~ s,::,/,g;
+ $mod .= '.pm';
+ eval { require $mod; };
+ exists $Encoding{$name} and return $Encoding{$name};
+ }
+ }
+ return;
+}
+
+sub find_encoding($;$) {
+ my ( $name, $skip_external ) = @_;
+ return __PACKAGE__->getEncoding( $name, $skip_external );
+}
+
+sub resolve_alias($) {
+ my $obj = find_encoding(shift);
+ defined $obj and return $obj->name;
+ return;
+}
+
+sub clone_encoding($) {
+ my $obj = find_encoding(shift);
+ ref $obj or return;
+ eval { require Storable };
+ $@ and return;
+ return Storable::dclone($obj);
+}
+
+sub encode($$;$) {
+ my ( $name, $string, $check ) = @_;
+ return undef unless defined $string;
+ $string .= '' if ref $string; # stringify;
+ $check ||= 0;
+ unless ( defined $name ) {
+ require Carp;
+ Carp::croak("Encoding name should not be undef");
+ }
+ my $enc = find_encoding($name);
+ unless ( defined $enc ) {
+ require Carp;
+ Carp::croak("Unknown encoding '$name'");
+ }
+ my $octets = $enc->encode( $string, $check );
+ $_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() );
+ return $octets;
+}
+*str2bytes = \&encode;
+
+sub decode($$;$) {
+ my ( $name, $octets, $check ) = @_;
+ return undef unless defined $octets;
+ $octets .= '' if ref $octets;
+ $check ||= 0;
+ my $enc = find_encoding($name);
+ unless ( defined $enc ) {
+ require Carp;
+ Carp::croak("Unknown encoding '$name'");
+ }
+ my $string = $enc->decode( $octets, $check );
+ $_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
+ return $string;
+}
+*bytes2str = \&decode;
+
+sub from_to($$$;$) {
+ my ( $string, $from, $to, $check ) = @_;
+ return undef unless defined $string;
+ $check ||= 0;
+ my $f = find_encoding($from);
+ unless ( defined $f ) {
+ require Carp;
+ Carp::croak("Unknown encoding '$from'");
+ }
+ my $t = find_encoding($to);
+ unless ( defined $t ) {
+ require Carp;
+ Carp::croak("Unknown encoding '$to'");
+ }
+ my $uni = $f->decode($string);
+ $_[0] = $string = $t->encode( $uni, $check );
+ return undef if ( $check && length($uni) );
+ return defined( $_[0] ) ? length($string) : undef;
+}
+
+sub encode_utf8($) {
+ my ($str) = @_;
+ utf8::encode($str);
+ return $str;
+}
+
+sub decode_utf8($;$) {
+ my ( $str, $check ) = @_;
+ return $str if is_utf8($str);
+ if ($check) {
+ return decode( "utf8", $str, $check );
+ }
+ else {
+ return decode( "utf8", $str );
+ return $str;
+ }
+}
+
+predefine_encodings(1);
+
+#
+# This is to restore %Encoding if really needed;
+#
+
+sub predefine_encodings {
+ require Encode::Encoding;
+ no warnings 'redefine';
+ my $use_xs = shift;
+ if ($ON_EBCDIC) {
+
+ # was in Encode::UTF_EBCDIC
+ package Encode::UTF_EBCDIC;
+ push @Encode::UTF_EBCDIC::ISA, 'Encode::Encoding';
+ *decode = sub {
+ my ( $obj, $str, $chk ) = @_;
+ my $res = '';
+ for ( my $i = 0 ; $i < length($str) ; $i++ ) {
+ $res .=
+ chr(
+ utf8::unicode_to_native( ord( substr( $str, $i, 1 ) ) )
+ );
+ }
+ $_[1] = '' if $chk;
+ return $res;
+ };
+ *encode = sub {
+ my ( $obj, $str, $chk ) = @_;
+ my $res = '';
+ for ( my $i = 0 ; $i < length($str) ; $i++ ) {
+ $res .=
+ chr(
+ utf8::native_to_unicode( ord( substr( $str, $i, 1 ) ) )
+ );
+ }
+ $_[1] = '' if $chk;
+ return $res;
+ };
+ $Encode::Encoding{Unicode} =
+ bless { Name => "UTF_EBCDIC" } => "Encode::UTF_EBCDIC";
+ }
+ else {
+
+ package Encode::Internal;
+ push @Encode::Internal::ISA, 'Encode::Encoding';
+ *decode = sub {
+ my ( $obj, $str, $chk ) = @_;
+ utf8::upgrade($str);
+ $_[1] = '' if $chk;
+ return $str;
+ };
+ *encode = \&decode;
+ $Encode::Encoding{Unicode} =
+ bless { Name => "Internal" } => "Encode::Internal";
+ }
+
+ {
+
+ # was in Encode::utf8
+ package Encode::utf8;
+ push @Encode::utf8::ISA, 'Encode::Encoding';
+
+ #
+ if ($use_xs) {
+ Encode::DEBUG and warn __PACKAGE__, " XS on";
+ *decode = \&decode_xs;
+ *encode = \&encode_xs;
+ }
+ else {
+ Encode::DEBUG and warn __PACKAGE__, " XS off";
+ *decode = sub {
+ my ( $obj, $octets, $chk ) = @_;
+ my $str = Encode::decode_utf8($octets);
+ if ( defined $str ) {
+ $_[1] = '' if $chk;
+ return $str;
+ }
+ return undef;
+ };
+ *encode = sub {
+ my ( $obj, $string, $chk ) = @_;
+ my $octets = Encode::encode_utf8($string);
+ $_[1] = '' if $chk;
+ return $octets;
+ };
+ }
+ *cat_decode = sub { # ($obj, $dst, $src, $pos, $trm, $chk)
+ # currently ignores $chk
+ my ( $obj, undef, undef, $pos, $trm ) = @_;
+ my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ];
+ use bytes;
+ if ( ( my $npos = index( $$rsrc, $trm, $pos ) ) >= 0 ) {
+ $$rdst .=
+ substr( $$rsrc, $pos, $npos - $pos + length($trm) );
+ $$rpos = $npos + length($trm);
+ return 1;
+ }
+ $$rdst .= substr( $$rsrc, $pos );
+ $$rpos = length($$rsrc);
+ return '';
+ };
+ $Encode::Encoding{utf8} =
+ bless { Name => "utf8" } => "Encode::utf8";
+ $Encode::Encoding{"utf-8-strict"} =
+ bless { Name => "utf-8-strict", strict_utf8 => 1 } =>
+ "Encode::utf8";
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Encode - character encodings
+
+=head1 SYNOPSIS
+
+ use Encode;
+
+=head2 Table of Contents
+
+Encode consists of a collection of modules whose details are too big
+to fit in one document. This POD itself explains the top-level APIs
+and general topics at a glance. For other topics and more details,
+see the PODs below:
+
+ Name Description
+ --------------------------------------------------------
+ Encode::Alias Alias definitions to encodings
+ Encode::Encoding Encode Implementation Base Class
+ Encode::Supported List of Supported Encodings
+ Encode::CN Simplified Chinese Encodings
+ Encode::JP Japanese Encodings
+ Encode::KR Korean Encodings
+ Encode::TW Traditional Chinese Encodings
+ --------------------------------------------------------
+
+=head1 DESCRIPTION
+
+The C<Encode> module provides the interfaces between Perl's strings
+and the rest of the system. Perl strings are sequences of
+B<characters>.
+
+The repertoire of characters that Perl can represent is at least that
+defined by the Unicode Consortium. On most platforms the ordinal
+values of the characters (as returned by C<ord(ch)>) is the "Unicode
+codepoint" for the character (the exceptions are those platforms where
+the legacy encoding is some variant of EBCDIC rather than a super-set
+of ASCII - see L<perlebcdic>).
+
+Traditionally, computer data has been moved around in 8-bit chunks
+often called "bytes". These chunks are also known as "octets" in
+networking standards. Perl is widely used to manipulate data of many
+types - not only strings of characters representing human or computer
+languages but also "binary" data being the machine's representation of
+numbers, pixels in an image - or just about anything.
+
+When Perl is processing "binary data", the programmer wants Perl to
+process "sequences of bytes". This is not a problem for Perl - as a
+byte has 256 possible values, it easily fits in Perl's much larger
+"logical character".
+
+=head2 TERMINOLOGY
+
+=over 2
+
+=item *
+
+I<character>: a character in the range 0..(2**32-1) (or more).
+(What Perl's strings are made of.)
+
+=item *
+
+I<byte>: a character in the range 0..255
+(A special case of a Perl character.)
+
+=item *
+
+I<octet>: 8 bits of data, with ordinal values 0..255
+(Term for bytes passed to or from a non-Perl context, e.g. a disk file.)
+
+=back
+
+=head1 PERL ENCODING API
+
+=over 2
+
+=item $octets = encode(ENCODING, $string [, CHECK])
+
+Encodes a string from Perl's internal form into I<ENCODING> and returns
+a sequence of octets. ENCODING can be either a canonical name or
+an alias. For encoding names and aliases, see L</"Defining Aliases">.
+For CHECK, see L</"Handling Malformed Data">.
+
+For example, to convert a string from Perl's internal format to
+iso-8859-1 (also known as Latin1),
+
+ $octets = encode("iso-8859-1", $string);
+
+B<CAVEAT>: When you run C<$octets = encode("utf8", $string)>, then
+$octets B<may not be equal to> $string. Though they both contain the
+same data, the UTF8 flag for $octets is B<always> off. When you
+encode anything, UTF8 flag of the result is always off, even when it
+contains completely valid utf8 string. See L</"The UTF8 flag"> below.
+
+If the $string is C<undef> then C<undef> is returned.
+
+=item $string = decode(ENCODING, $octets [, CHECK])
+
+Decodes a sequence of octets assumed to be in I<ENCODING> into Perl's
+internal form and returns the resulting string. As in encode(),
+ENCODING can be either a canonical name or an alias. For encoding names
+and aliases, see L</"Defining Aliases">. For CHECK, see
+L</"Handling Malformed Data">.
+
+For example, to convert ISO-8859-1 data to a string in Perl's internal format:
+
+ $string = decode("iso-8859-1", $octets);
+
+B<CAVEAT>: When you run C<$string = decode("utf8", $octets)>, then $string
+B<may not be equal to> $octets. Though they both contain the same data,
+the UTF8 flag for $string is on unless $octets entirely consists of
+ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF8 flag">
+below.
+
+If the $string is C<undef> then C<undef> is returned.
+
+=item [$obj =] find_encoding(ENCODING)
+
+Returns the I<encoding object> corresponding to ENCODING. Returns
+undef if no matching ENCODING is find.
+
+This object is what actually does the actual (en|de)coding.
+
+ $utf8 = decode($name, $bytes);
+
+is in fact
+
+ $utf8 = do{
+ $obj = find_encoding($name);
+ croak qq(encoding "$name" not found) unless ref $obj;
+ $obj->decode($bytes)
+ };
+
+with more error checking.
+
+Therefore you can save time by reusing this object as follows;
+
+ my $enc = find_encoding("iso-8859-1");
+ while(<>){
+ my $utf8 = $enc->decode($_);
+ # and do someting with $utf8;
+ }
+
+Besides C<< ->decode >> and C<< ->encode >>, other methods are
+available as well. For instance, C<< -> name >> returns the canonical
+name of the encoding object.
+
+ find_encoding("latin1")->name; # iso-8859-1
+
+See L<Encode::Encoding> for details.
+
+=item [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
+
+Converts B<in-place> data between two encodings. The data in $octets
+must be encoded as octets and not as characters in Perl's internal
+format. For example, to convert ISO-8859-1 data to Microsoft's CP1250
+encoding:
+
+ from_to($octets, "iso-8859-1", "cp1250");
+
+and to convert it back:
+
+ from_to($octets, "cp1250", "iso-8859-1");
+
+Note that because the conversion happens in place, the data to be
+converted cannot be a string constant; it must be a scalar variable.
+
+from_to() returns the length of the converted string in octets on
+success, I<undef> on error.
+
+B<CAVEAT>: The following operations look the same but are not quite so;
+
+ from_to($data, "iso-8859-1", "utf8"); #1
+ $data = decode("iso-8859-1", $data); #2
+
+Both #1 and #2 make $data consist of a completely valid UTF-8 string
+but only #2 turns UTF8 flag on. #1 is equivalent to
+
+ $data = encode("utf8", decode("iso-8859-1", $data));
+
+See L</"The UTF8 flag"> below.
+
+Also note that
+
+ from_to($octets, $from, $to, $check);
+
+is equivalent to
+
+ $octets = encode($to, decode($from, $octets), $check);
+
+Yes, it does not respect the $check during decoding. It is
+deliberately done that way. If you need minute control, C<decode>
+then C<encode> as follows;
+
+ $octets = encode($to, decode($from, $octets, $check_from), $check_to);
+
+=item $octets = encode_utf8($string);
+
+Equivalent to C<$octets = encode("utf8", $string);> The characters
+that comprise $string are encoded in Perl's internal format and the
+result is returned as a sequence of octets. All possible
+characters have a UTF-8 representation so this function cannot fail.
+
+
+=item $string = decode_utf8($octets [, CHECK]);
+
+equivalent to C<$string = decode("utf8", $octets [, CHECK])>.
+The sequence of octets represented by
+$octets is decoded from UTF-8 into a sequence of logical
+characters. Not all sequences of octets form valid UTF-8 encodings, so
+it is possible for this call to fail. For CHECK, see
+L</"Handling Malformed Data">.
+
+=back
+
+=head2 Listing available encodings
+
+ use Encode;
+ @list = Encode->encodings();
+
+Returns a list of the canonical names of the available encodings that
+are loaded. To get a list of all available encodings including the
+ones that are not loaded yet, say
+
+ @all_encodings = Encode->encodings(":all");
+
+Or you can give the name of a specific module.
+
+ @with_jp = Encode->encodings("Encode::JP");
+
+When "::" is not in the name, "Encode::" is assumed.
+
+ @ebcdic = Encode->encodings("EBCDIC");
+
+To find out in detail which encodings are supported by this package,
+see L<Encode::Supported>.
+
+=head2 Defining Aliases
+
+To add a new alias to a given encoding, use:
+
+ use Encode;
+ use Encode::Alias;
+ define_alias(newName => ENCODING);
+
+After that, newName can be used as an alias for ENCODING.
+ENCODING may be either the name of an encoding or an
+I<encoding object>
+
+But before you do so, make sure the alias is nonexistent with
+C<resolve_alias()>, which returns the canonical name thereof.
+i.e.
+
+ Encode::resolve_alias("latin1") eq "iso-8859-1" # true
+ Encode::resolve_alias("iso-8859-12") # false; nonexistent
+ Encode::resolve_alias($name) eq $name # true if $name is canonical
+
+resolve_alias() does not need C<use Encode::Alias>; it can be
+exported via C<use Encode qw(resolve_alias)>.
+
+See L<Encode::Alias> for details.
+
+=head2 Finding IANA Character Set Registry names
+
+The canonical name of a given encoding does not necessarily agree with
+IANA IANA Character Set Registry, commonly seen as C<< Content-Type:
+text/plain; charset=I<whatever> >>. For most cases canonical names
+work but sometimes it does not (notably 'utf-8-strict').
+
+Therefore as of Encode version 2.21, a new method C<mime_name()> is added.
+
+ use Encode;
+ my $enc = find_encoding('UTF-8');
+ warn $enc->name; # utf-8-strict
+ warn $enc->mime_name; # UTF-8
+
+See also: L<Encode::Encoding>
+
+=head1 Encoding via PerlIO
+
+If your perl supports I<PerlIO> (which is the default), you can use a
+PerlIO layer to decode and encode directly via a filehandle. The
+following two examples are totally identical in their functionality.
+
+ # via PerlIO
+ open my $in, "<:encoding(shiftjis)", $infile or die;
+ open my $out, ">:encoding(euc-jp)", $outfile or die;
+ while(<$in>){ print $out $_; }
+
+ # via from_to
+ open my $in, "<", $infile or die;
+ open my $out, ">", $outfile or die;
+ while(<$in>){
+ from_to($_, "shiftjis", "euc-jp", 1);
+ print $out $_;
+ }
+
+Unfortunately, it may be that encodings are PerlIO-savvy. You can check
+if your encoding is supported by PerlIO by calling the C<perlio_ok>
+method.
+
+ Encode::perlio_ok("hz"); # False
+ find_encoding("euc-cn")->perlio_ok; # True where PerlIO is available
+
+ use Encode qw(perlio_ok); # exported upon request
+ perlio_ok("euc-jp")
+
+Fortunately, all encodings that come with Encode core are PerlIO-savvy
+except for hz and ISO-2022-kr. For gory details, see
+L<Encode::Encoding> and L<Encode::PerlIO>.
+
+=head1 Handling Malformed Data
+
+The optional I<CHECK> argument tells Encode what to do when it
+encounters malformed data. Without CHECK, Encode::FB_DEFAULT ( == 0 )
+is assumed.
+
+As of version 2.12 Encode supports coderef values for CHECK. See below.
+
+=over 2
+
+=item B<NOTE:> Not all encoding support this feature
+
+Some encodings ignore I<CHECK> argument. For example,
+L<Encode::Unicode> ignores I<CHECK> and it always croaks on error.
+
+=back
+
+Now here is the list of I<CHECK> values available
+
+=over 2
+
+=item I<CHECK> = Encode::FB_DEFAULT ( == 0)
+
+If I<CHECK> is 0, (en|de)code will put a I<substitution character> in
+place of a malformed character. When you encode, E<lt>subcharE<gt>
+will be used. When you decode the code point C<0xFFFD> is used. If
+the data is supposed to be UTF-8, an optional lexical warning
+(category utf8) is given.
+
+=item I<CHECK> = Encode::FB_CROAK ( == 1)
+
+If I<CHECK> is 1, methods will die on error immediately with an error
+message. Therefore, when I<CHECK> is set to 1, you should trap the
+error with eval{} unless you really want to let it die.
+
+=item I<CHECK> = Encode::FB_QUIET
+
+If I<CHECK> is set to Encode::FB_QUIET, (en|de)code will immediately
+return the portion of the data that has been processed so far when an
+error occurs. The data argument will be overwritten with everything
+after that point (that is, the unprocessed part of data). This is
+handy when you have to call decode repeatedly in the case where your
+source data may contain partial multi-byte character sequences,
+(i.e. you are reading with a fixed-width buffer). Here is a sample
+code that does exactly this:
+
+ my $buffer = ''; my $string = '';
+ while(read $fh, $buffer, 256, length($buffer)){
+ $string .= decode($encoding, $buffer, Encode::FB_QUIET);
+ # $buffer now contains the unprocessed partial character
+ }
+
+=item I<CHECK> = Encode::FB_WARN
+
+This is the same as above, except that it warns on error. Handy when
+you are debugging the mode above.
+
+=item perlqq mode (I<CHECK> = Encode::FB_PERLQQ)
+
+=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF)
+
+=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF)
+
+For encodings that are implemented by Encode::XS, CHECK ==
+Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode.
+
+When you decode, C<\xI<HH>> will be inserted for a malformed character,
+where I<HH> is the hex representation of the octet that could not be
+decoded to utf8. And when you encode, C<\x{I<HHHH>}> will be inserted,
+where I<HHHH> is the Unicode ID of the character that cannot be found
+in the character repertoire of the encoding.
+
+HTML/XML character reference modes are about the same, in place of
+C<\x{I<HHHH>}>, HTML uses C<&#I<NNN>;> where I<NNN> is a decimal number and
+XML uses C<&#xI<HHHH>;> where I<HHHH> is the hexadecimal number.
+
+In Encode 2.10 or later, C<LEAVE_SRC> is also implied.
+
+=item The bitmask
+
+These modes are actually set via a bitmask. Here is how the FB_XX
+constants are laid out. You can import the FB_XX constants via
+C<use Encode qw(:fallbacks)>; you can import the generic bitmask
+constants via C<use Encode qw(:fallback_all)>.
+
+ FB_DEFAULT FB_CROAK FB_QUIET FB_WARN FB_PERLQQ
+ DIE_ON_ERR 0x0001 X
+ WARN_ON_ERR 0x0002 X
+ RETURN_ON_ERR 0x0004 X X
+ LEAVE_SRC 0x0008 X
+ PERLQQ 0x0100 X
+ HTMLCREF 0x0200
+ XMLCREF 0x0400
+
+=back
+
+=over 2
+
+=item Encode::LEAVE_SRC
+
+If the C<Encode::LEAVE_SRC> bit is not set, but I<CHECK> is, then the second
+argument to C<encode()> or C<decode()> may be assigned to by the functions. If
+you're not interested in this, then bitwise-or the bitmask with it.
+
+=back
+
+=head2 coderef for CHECK
+
+As of Encode 2.12 CHECK can also be a code reference which takes the
+ord value of unmapped caharacter as an argument and returns a string
+that represents the fallback character. For instance,
+
+ $ascii = encode("ascii", $utf8, sub{ sprintf "<U+%04X>", shift });
+
+Acts like FB_PERLQQ but E<lt>U+I<XXXX>E<gt> is used instead of
+\x{I<XXXX>}.
+
+=head1 Defining Encodings
+
+To define a new encoding, use:
+
+ use Encode qw(define_encoding);
+ define_encoding($object, 'canonicalName' [, alias...]);
+
+I<canonicalName> will be associated with I<$object>. The object
+should provide the interface described in L<Encode::Encoding>.
+If more than two arguments are provided then additional
+arguments are taken as aliases for I<$object>.
+
+See L<Encode::Encoding> for more details.
+
+=head1 The UTF8 flag
+
+Before the introduction of Unicode support in perl, The C<eq> operator
+just compared the strings represented by two scalars. Beginning with
+perl 5.8, C<eq> compares two strings with simultaneous consideration of
+I<the UTF8 flag>. To explain why we made it so, I will quote page 402 of
+C<Programming Perl, 3rd ed.>
+
+=over 2
+
+=item Goal #1:
+
+Old byte-oriented programs should not spontaneously break on the old
+byte-oriented data they used to work on.
+
+=item Goal #2:
+
+Old byte-oriented programs should magically start working on the new
+character-oriented data when appropriate.
+
+=item Goal #3:
+
+Programs should run just as fast in the new character-oriented mode
+as in the old byte-oriented mode.
+
+=item Goal #4:
+
+Perl should remain one language, rather than forking into a
+byte-oriented Perl and a character-oriented Perl.
+
+=back
+
+Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0
+was born and many features documented in the book remained
+unimplemented for a long time. Perl 5.8 corrected this and the introduction
+of the UTF8 flag is one of them. You can think of this perl notion as of a
+byte-oriented mode (UTF8 flag off) and a character-oriented mode (UTF8
+flag on).
+
+Here is how Encode takes care of the UTF8 flag.
+
+=over 2
+
+=item *
+
+When you encode, the resulting UTF8 flag is always off.
+
+=item *
+
+When you decode, the resulting UTF8 flag is on unless you can
+unambiguously represent data. Here is the definition of
+dis-ambiguity.
+
+After C<$utf8 = decode('foo', $octet);>,
+
+ When $octet is... The UTF8 flag in $utf8 is
+ ---------------------------------------------
+ In ASCII only (or EBCDIC only) OFF
+ In ISO-8859-1 ON
+ In any other Encoding ON
+ ---------------------------------------------
+
+As you see, there is one exception, In ASCII. That way you can assume
+Goal #1. And with Encode Goal #2 is assumed but you still have to be
+careful in such cases mentioned in B<CAVEAT> paragraphs.
+
+This UTF8 flag is not visible in perl scripts, exactly for the same
+reason you cannot (or you I<don't have to>) see if a scalar contains a
+string, integer, or floating point number. But you can still peek
+and poke these if you will. See the section below.
+
+=back
+
+=head2 Messing with Perl's Internals
+
+The following API uses parts of Perl's internals in the current
+implementation. As such, they are efficient but may change.
+
+=over 2
+
+=item is_utf8(STRING [, CHECK])
+
+[INTERNAL] Tests whether the UTF8 flag is turned on in the STRING.
+If CHECK is true, also checks the data in STRING for being well-formed
+UTF-8. Returns true if successful, false otherwise.
+
+As of perl 5.8.1, L<utf8> also has utf8::is_utf8().
+
+=item _utf8_on(STRING)
+
+[INTERNAL] Turns on the UTF8 flag in STRING. The data in STRING is
+B<not> checked for being well-formed UTF-8. Do not use unless you
+B<know> that the STRING is well-formed UTF-8. Returns the previous
+state of the UTF8 flag (so please don't treat the return value as
+indicating success or failure), or C<undef> if STRING is not a string.
+
+This function does not work on tainted values.
+
+=item _utf8_off(STRING)
+
+[INTERNAL] Turns off the UTF8 flag in STRING. Do not use frivolously.
+Returns the previous state of the UTF8 flag (so please don't treat the
+return value as indicating success or failure), or C<undef> if STRING is
+not a string.
+
+This function does not work on tainted values.
+
+=back
+
+=head1 UTF-8 vs. utf8 vs. UTF8
+
+ ....We now view strings not as sequences of bytes, but as sequences
+ of numbers in the range 0 .. 2**32-1 (or in the case of 64-bit
+ computers, 0 .. 2**64-1) -- Programming Perl, 3rd ed.
+
+That has been the perl's notion of UTF-8 but official UTF-8 is more
+strict; Its ranges is much narrower (0 .. 10FFFF), some sequences are
+not allowed (i.e. Those used in the surrogate pair, 0xFFFE, et al).
+
+Now that is overruled by Larry Wall himself.
+
+ From: Larry Wall <larry@wall.org>
+ Date: December 04, 2004 11:51:58 JST
+ To: perl-unicode@perl.org
+ Subject: Re: Make Encode.pm support the real UTF-8
+ Message-Id: <20041204025158.GA28754@wall.org>
+
+ On Fri, Dec 03, 2004 at 10:12:12PM +0000, Tim Bunce wrote:
+ : I've no problem with 'utf8' being perl's unrestricted uft8 encoding,
+ : but "UTF-8" is the name of the standard and should give the
+ : corresponding behaviour.
+
+ For what it's worth, that's how I've always kept them straight in my
+ head.
+
+ Also for what it's worth, Perl 6 will mostly default to strict but
+ make it easy to switch back to lax.
+
+ Larry
+
+Do you copy? As of Perl 5.8.7, B<UTF-8> means strict, official UTF-8
+while B<utf8> means liberal, lax, version thereof. And Encode version
+2.10 or later thus groks the difference between C<UTF-8> and C"utf8".
+
+ encode("utf8", "\x{FFFF_FFFF}", 1); # okay
+ encode("UTF-8", "\x{FFFF_FFFF}", 1); # croaks
+
+C<UTF-8> in Encode is actually a canonical name for C<utf-8-strict>.
+Yes, the hyphen between "UTF" and "8" is important. Without it Encode
+goes "liberal"
+
+ find_encoding("UTF-8")->name # is 'utf-8-strict'
+ find_encoding("utf-8")->name # ditto. names are case insensitive
+ find_encoding("utf_8")->name # ditto. "_" are treated as "-"
+ find_encoding("UTF8")->name # is 'utf8'.
+
+The UTF8 flag is internally called UTF8, without a hyphen. It indicates
+whether a string is internally encoded as utf8, also without a hypen.
+
+=head1 SEE ALSO
+
+L<Encode::Encoding>,
+L<Encode::Supported>,
+L<Encode::PerlIO>,
+L<encoding>,
+L<perlebcdic>,
+L<perlfunc/open>,
+L<perlunicode>, L<perluniintro>, L<perlunifaq>, L<perlunitut>
+L<utf8>,
+the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt>
+
+=head1 MAINTAINER
+
+This project was originated by Nick Ing-Simmons and later maintained
+by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full
+list of people involved. For any questions, use
+E<lt>perl-unicode@perl.orgE<gt> so we can all share.
+
+While Dan Kogai retains the copyright as a maintainer, the credit
+should go to all those involoved. See AUTHORS for those submitted
+codes.
+
+=head1 COPYRIGHT
+
+Copyright 2002-2006 Dan Kogai E<lt>dankogai@dan.co.jpE<gt>
+
+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/English.pm b/Master/tlpkg/tlperl/lib/English.pm
new file mode 100644
index 00000000000..c11fbed9eba
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/English.pm
@@ -0,0 +1,230 @@
+package English;
+
+our $VERSION = '1.04';
+
+require Exporter;
+@ISA = qw(Exporter);
+
+=head1 NAME
+
+English - use nice English (or awk) names for ugly punctuation variables
+
+=head1 SYNOPSIS
+
+ use English qw( -no_match_vars ) ; # Avoids regex performance penalty
+ use English;
+ ...
+ if ($ERRNO =~ /denied/) { ... }
+
+=head1 DESCRIPTION
+
+This module provides aliases for the built-in variables whose
+names no one seems to like to read. Variables with side-effects
+which get triggered just by accessing them (like $0) will still
+be affected.
+
+For those variables that have an B<awk> version, both long
+and short English alternatives are provided. For example,
+the C<$/> variable can be referred to either $RS or
+$INPUT_RECORD_SEPARATOR if you are using the English module.
+
+See L<perlvar> for a complete list of these.
+
+=head1 PERFORMANCE
+
+This module can provoke sizeable inefficiencies for regular expressions,
+due to unfortunate implementation details. If performance matters in
+your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
+try doing
+
+ use English qw( -no_match_vars ) ;
+
+. B<It is especially important to do this in modules to avoid penalizing
+all applications which use them.>
+
+=cut
+
+no warnings;
+
+my $globbed_match ;
+
+# Grandfather $NAME import
+sub import {
+ my $this = shift;
+ my @list = grep { ! /^-no_match_vars$/ } @_ ;
+ local $Exporter::ExportLevel = 1;
+ if ( @_ == @list ) {
+ *EXPORT = \@COMPLETE_EXPORT ;
+ $globbed_match ||= (
+ eval q{
+ *MATCH = *& ;
+ *PREMATCH = *` ;
+ *POSTMATCH = *' ;
+ 1 ;
+ }
+ || do {
+ require Carp ;
+ Carp::croak("Can't create English for match leftovers: $@") ;
+ }
+ ) ;
+ }
+ else {
+ *EXPORT = \@MINIMAL_EXPORT ;
+ }
+ Exporter::import($this,grep {s/^\$/*/} @list);
+}
+
+@MINIMAL_EXPORT = qw(
+ *ARG
+ *LAST_PAREN_MATCH
+ *INPUT_LINE_NUMBER
+ *NR
+ *INPUT_RECORD_SEPARATOR
+ *RS
+ *OUTPUT_AUTOFLUSH
+ *OUTPUT_FIELD_SEPARATOR
+ *OFS
+ *OUTPUT_RECORD_SEPARATOR
+ *ORS
+ *LIST_SEPARATOR
+ *SUBSCRIPT_SEPARATOR
+ *SUBSEP
+ *FORMAT_PAGE_NUMBER
+ *FORMAT_LINES_PER_PAGE
+ *FORMAT_LINES_LEFT
+ *FORMAT_NAME
+ *FORMAT_TOP_NAME
+ *FORMAT_LINE_BREAK_CHARACTERS
+ *FORMAT_FORMFEED
+ *CHILD_ERROR
+ *OS_ERROR
+ *ERRNO
+ *EXTENDED_OS_ERROR
+ *EVAL_ERROR
+ *PROCESS_ID
+ *PID
+ *REAL_USER_ID
+ *UID
+ *EFFECTIVE_USER_ID
+ *EUID
+ *REAL_GROUP_ID
+ *GID
+ *EFFECTIVE_GROUP_ID
+ *EGID
+ *PROGRAM_NAME
+ *PERL_VERSION
+ *ACCUMULATOR
+ *COMPILING
+ *DEBUGGING
+ *SYSTEM_FD_MAX
+ *INPLACE_EDIT
+ *PERLDB
+ *BASETIME
+ *WARNING
+ *EXECUTABLE_NAME
+ *OSNAME
+ *LAST_REGEXP_CODE_RESULT
+ *EXCEPTIONS_BEING_CAUGHT
+ *LAST_SUBMATCH_RESULT
+ @LAST_MATCH_START
+ @LAST_MATCH_END
+);
+
+
+@MATCH_EXPORT = qw(
+ *MATCH
+ *PREMATCH
+ *POSTMATCH
+);
+
+@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ;
+
+# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)
+
+ *ARG = *_ ;
+
+# Matching.
+
+ *LAST_PAREN_MATCH = *+ ;
+ *LAST_SUBMATCH_RESULT = *^N ;
+ *LAST_MATCH_START = *-{ARRAY} ;
+ *LAST_MATCH_END = *+{ARRAY} ;
+
+# Input.
+
+ *INPUT_LINE_NUMBER = *. ;
+ *NR = *. ;
+ *INPUT_RECORD_SEPARATOR = */ ;
+ *RS = */ ;
+
+# Output.
+
+ *OUTPUT_AUTOFLUSH = *| ;
+ *OUTPUT_FIELD_SEPARATOR = *, ;
+ *OFS = *, ;
+ *OUTPUT_RECORD_SEPARATOR = *\ ;
+ *ORS = *\ ;
+
+# Interpolation "constants".
+
+ *LIST_SEPARATOR = *" ;
+ *SUBSCRIPT_SEPARATOR = *; ;
+ *SUBSEP = *; ;
+
+# Formats
+
+ *FORMAT_PAGE_NUMBER = *% ;
+ *FORMAT_LINES_PER_PAGE = *= ;
+ *FORMAT_LINES_LEFT = *- ;
+ *FORMAT_NAME = *~ ;
+ *FORMAT_TOP_NAME = *^ ;
+ *FORMAT_LINE_BREAK_CHARACTERS = *: ;
+ *FORMAT_FORMFEED = *^L ;
+
+# Error status.
+
+ *CHILD_ERROR = *? ;
+ *OS_ERROR = *! ;
+ *ERRNO = *! ;
+ *OS_ERROR = *! ;
+ *ERRNO = *! ;
+ *EXTENDED_OS_ERROR = *^E ;
+ *EVAL_ERROR = *@ ;
+
+# Process info.
+
+ *PROCESS_ID = *$ ;
+ *PID = *$ ;
+ *REAL_USER_ID = *< ;
+ *UID = *< ;
+ *EFFECTIVE_USER_ID = *> ;
+ *EUID = *> ;
+ *REAL_GROUP_ID = *( ;
+ *GID = *( ;
+ *EFFECTIVE_GROUP_ID = *) ;
+ *EGID = *) ;
+ *PROGRAM_NAME = *0 ;
+
+# Internals.
+
+ *PERL_VERSION = *^V ;
+ *ACCUMULATOR = *^A ;
+ *COMPILING = *^C ;
+ *DEBUGGING = *^D ;
+ *SYSTEM_FD_MAX = *^F ;
+ *INPLACE_EDIT = *^I ;
+ *PERLDB = *^P ;
+ *LAST_REGEXP_CODE_RESULT = *^R ;
+ *EXCEPTIONS_BEING_CAUGHT = *^S ;
+ *BASETIME = *^T ;
+ *WARNING = *^W ;
+ *EXECUTABLE_NAME = *^X ;
+ *OSNAME = *^O ;
+
+# Deprecated.
+
+# *ARRAY_BASE = *[ ;
+# *OFMT = *# ;
+# *OLD_PERL_VERSION = *] ;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Env.pm b/Master/tlpkg/tlperl/lib/Env.pm
new file mode 100644
index 00000000000..deac5fc4b92
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Env.pm
@@ -0,0 +1,254 @@
+package Env;
+
+our $VERSION = '1.01';
+
+=head1 NAME
+
+Env - perl module that imports environment variables as scalars or arrays
+
+=head1 SYNOPSIS
+
+ use Env;
+ use Env qw(PATH HOME TERM);
+ use Env qw($SHELL @LD_LIBRARY_PATH);
+
+=head1 DESCRIPTION
+
+Perl maintains environment variables in a special hash named C<%ENV>. For
+when this access method is inconvenient, the Perl module C<Env> allows
+environment variables to be treated as scalar or array variables.
+
+The C<Env::import()> function ties environment variables with suitable
+names to global Perl variables with the same names. By default it
+ties all existing environment variables (C<keys %ENV>) to scalars. If
+the C<import> function receives arguments, it takes them to be a list of
+variables to tie; it's okay if they don't yet exist. The scalar type
+prefix '$' is inferred for any element of this list not prefixed by '$'
+or '@'. Arrays are implemented in terms of C<split> and C<join>, using
+C<$Config::Config{path_sep}> as the delimiter.
+
+After an environment variable is tied, merely use it like a normal variable.
+You may access its value
+
+ @path = split(/:/, $PATH);
+ print join("\n", @LD_LIBRARY_PATH), "\n";
+
+or modify it
+
+ $PATH .= ":.";
+ push @LD_LIBRARY_PATH, $dir;
+
+however you'd like. Bear in mind, however, that each access to a tied array
+variable requires splitting the environment variable's string anew.
+
+The code:
+
+ use Env qw(@PATH);
+ push @PATH, '.';
+
+is equivalent to:
+
+ use Env qw(PATH);
+ $PATH .= ":.";
+
+except that if C<$ENV{PATH}> started out empty, the second approach leaves
+it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
+
+To remove a tied environment variable from
+the environment, assign it the undefined value
+
+ undef $PATH;
+ undef @LD_LIBRARY_PATH;
+
+=head1 LIMITATIONS
+
+On VMS systems, arrays tied to environment variables are read-only. Attempting
+to change anything will cause a warning.
+
+=head1 AUTHOR
+
+Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
+and
+Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>
+
+=cut
+
+sub import {
+ my ($callpack) = caller(0);
+ my $pack = shift;
+ my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
+ return unless @vars;
+
+ @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
+
+ eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
+ die $@ if $@;
+ foreach (@vars) {
+ my ($type, $name) = m/^([\$\@])(.*)$/;
+ if ($type eq '$') {
+ tie ${"${callpack}::$name"}, Env, $name;
+ } else {
+ if ($^O eq 'VMS') {
+ tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
+ } else {
+ tie @{"${callpack}::$name"}, Env::Array, $name;
+ }
+ }
+ }
+}
+
+sub TIESCALAR {
+ bless \($_[1]);
+}
+
+sub FETCH {
+ my ($self) = @_;
+ $ENV{$$self};
+}
+
+sub STORE {
+ my ($self, $value) = @_;
+ if (defined($value)) {
+ $ENV{$$self} = $value;
+ } else {
+ delete $ENV{$$self};
+ }
+}
+
+######################################################################
+
+package Env::Array;
+
+use Config;
+use Tie::Array;
+
+@ISA = qw(Tie::Array);
+
+my $sep = $Config::Config{path_sep};
+
+sub TIEARRAY {
+ bless \($_[1]);
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g);
+}
+
+sub STORESIZE {
+ my ($self, $size) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ $#temp = $size - 1;
+ $ENV{$$self} = join($sep, @temp);
+}
+
+sub CLEAR {
+ my ($self) = @_;
+ $ENV{$$self} = '';
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return (split($sep, $ENV{$$self}))[$index];
+}
+
+sub STORE {
+ my ($self, $index, $value) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ $temp[$index] = $value;
+ $ENV{$$self} = join($sep, @temp);
+ return $value;
+}
+
+sub EXISTS {
+ my ($self, $index) = @_;
+ return $index < $self->FETCHSIZE;
+}
+
+sub DELETE {
+ my ($self, $index) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $value = splice(@temp, $index, 1, ());
+ $ENV{$$self} = join($sep, @temp);
+ return $value;
+}
+
+sub PUSH {
+ my $self = shift;
+ my @temp = split($sep, $ENV{$$self});
+ push @temp, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return scalar(@temp);
+}
+
+sub POP {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = pop @temp;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub UNSHIFT {
+ my $self = shift;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = unshift @temp, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub SHIFT {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = shift @temp;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub SPLICE {
+ my $self = shift;
+ my $offset = shift;
+ my $length = shift;
+ my @temp = split($sep, $ENV{$$self});
+ if (wantarray) {
+ my @result = splice @temp, $self, $offset, $length, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return @result;
+ } else {
+ my $result = scalar splice @temp, $offset, $length, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+ }
+}
+
+######################################################################
+
+package Env::Array::VMS;
+use Tie::Array;
+
+@ISA = qw(Tie::Array);
+
+sub TIEARRAY {
+ bless \($_[1]);
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ my $i = 0;
+ while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
+ return $i;
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return $ENV{$$self . ';' . $index};
+}
+
+sub EXISTS {
+ my ($self, $index) = @_;
+ return $index < $self->FETCHSIZE;
+}
+
+sub DELETE { }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Errno.pm b/Master/tlpkg/tlperl/lib/Errno.pm
new file mode 100644
index 00000000000..b37d29e935f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Errno.pm
@@ -0,0 +1,2768 @@
+#
+# This file is auto-generated. ***ANY*** changes here will be lost
+#
+
+package Errno;
+our (@EXPORT_OK,%EXPORT_TAGS,@ISA,$VERSION,%errno,$AUTOLOAD);
+use Exporter ();
+use Config;
+use strict;
+
+"$Config{'archname'}-$Config{'osvers'}" eq
+"MSWin32-x86-multi-thread-5.1" or
+ die "Errno architecture (MSWin32-x86-multi-thread-5.1) does not match executable architecture ($Config{'archname'}-$Config{'osvers'})";
+
+$VERSION = "1.11";
+$VERSION = eval $VERSION;
+@ISA = qw(Exporter);
+
+@EXPORT_OK = qw(ERROR_LOGON_NOT_GRANTED ERROR_RESOURCE_ONLINE
+ ERROR_SINGLE_INSTANCE_APP E_NOINTERFACE ERROR_NO_SUCH_SITE
+ ERROR_CTX_LICENSE_CLIENT_INVALID ERROR_SXS_PROTECTION_CATALOG_FILE_MISSING
+ ERROR_VOLUME_CONTAINS_SYS_FILES EMR_CREATEBRUSHINDIRECT
+ ERROR_DIR_NOT_EMPTY EXCEPTION_INVALID_DISPOSITION ERROR_OPEN_FAILED
+ ERROR_DS_CANT_MOVE_ACCOUNT_GROUP ERROR_SXS_XML_E_INVALID_DECIMAL
+ ERROR_NOT_SUPPORTED ERROR_CTX_NOT_CONSOLE ERROR_USER_MAPPED_FILE
+ ERROR_DS_CANT_TREE_DELETE_CRITICAL_OBJ EN_SETFOCUS ERROR_OUT_OF_PAPER
+ ERROR_DS_CANT_MOVE_DELETED_OBJECT ERROR_NODE_CANNOT_BE_CLUSTERED
+ ENUM_REGISTRY_SETTINGS ERROR_WRONG_TARGET_NAME ERROR_INVALID_TIME
+ ERROR_CONNECTION_ACTIVE ERROR_IPSEC_MM_AUTH_IN_USE
+ ERROR_SXS_XML_E_BADXMLDECL ESB_DISABLE_LEFT ERROR_INVALID_COLORSPACE
+ ERROR_PATH_BUSY ERROR_DS_THREAD_LIMIT_EXCEEDED ETO_OPAQUE
+ ERROR_CLUSTERLOG_CHKPOINT_NOT_FOUND EISCONN ERROR_IS_SUBST_PATH
+ ERROR_NOTIFY_ENUM_DIR ERROR_SPECIAL_ACCOUNT ERROR_DS_DRA_SINK_DISABLED
+ EMR_SAVEDC ERROR_DELETE_PENDING ENABLE_QUICK_EDIT_MODE
+ ERROR_DS_EXISTS_IN_MAY_HAVE ERROR_CLUSTER_NETWORK_EXISTS
+ ERROR_ICM_NOT_ENABLED EM_GETWORDBREAKPROC ERROR_DS_SAM_NEED_BOOTKEY_FLOPPY
+ ERROR_PRINTER_DRIVER_ALREADY_INSTALLED ERROR_SXS_XML_E_INVALID_STANDALONE
+ ERROR_NOT_DOS_DISK ERROR_DS_NTDSCRIPT_PROCESS_ERROR
+ ERROR_CTX_CLIENT_QUERY_TIMEOUT ERROR_SET_NOT_FOUND
+ ERROR_DS_PDC_OPERATION_IN_PROGRESS ERROR_DS_UNIVERSAL_CANT_HAVE_LOCAL_MEMBER
+ ERROR_NO_DATA ERROR_IPSEC_TUNNEL_FILTER_EXISTS ERROR_CLUSTER_INVALID_REQUEST
+ ERROR_DS_SUBREF_MUST_HAVE_PARENT ERROR_NO_TRUST_SAM_ACCOUNT
+ EMR_SETTEXTCOLOR ERROR_IPSEC_DEFAULT_MM_AUTH_NOT_FOUND
+ ERROR_DS_ROOT_REQUIRES_CLASS_TOP ERROR_SXS_XML_E_INVALID_VERSION EIO
+ EAFNOSUPPORT ERROR_DS_COUNTING_AB_INDICES_FAILED ERROR_DS_COMPARE_TRUE
+ ERROR_CLEANER_CARTRIDGE_INSTALLED ERROR_INDIGENOUS_TYPE
+ ERROR_CTX_SERVICE_NAME_COLLISION ERROR_SYNC_FOREGROUND_REFRESH_REQUIRED
+ ERROR ERROR_CANT_RESOLVE_FILENAME ERROR_NOT_QUORUM_CLASS
+ ERROR_DS_CONSTRUCTED_ATT_MOD EMR_CREATEDIBPATTERNBRUSHPT
+ ERROR_IS_JOIN_PATH ERROR_IPSEC_IKE_NO_POLICY EM_LINEFROMCHAR
+ ERROR_SYSTEM_TRACE ERROR_BUS_RESET ERROR_DS_CANT_MOD_SYSTEM_ONLY
+ ERROR_IPSEC_IKE_INVALID_POLICY ERROR_DEVICE_IN_USE
+ ERROR_CTX_CLIENT_LICENSE_IN_USE ERROR_DS_HAVE_PRIMARY_MEMBERS
+ ERROR_INVALID_SIGNAL_NUMBER ERROR_IPSEC_IKE_NO_PRIVATE_KEY
+ ERROR_DEVICE_REMOVED ERROR_DS_CODE_INCONSISTENCY ERROR_ACCESS_DISABLED_WEBBLADE_TAMPER
+ ERROR_DS_OBJ_CLASS_VIOLATION ERROR_BAD_INHERITANCE_ACL
+ ESB_DISABLE_RTDN ERROR_IPSEC_IKE_INVALID_HEADER ERROR_INVALID_SEGDPL
+ ERROR_PRINTER_DELETED ERROR_CLUSTER_DATABASE_SEQMISMATCH ERROR_BADDB
+ ERROR_DIFFERENT_SERVICE_ACCOUNT ERROR_OBJECT_IN_LIST
+ ERROR_INVALID_STARTING_CODESEG ERROR_DUPLICATE_SERVICE_NAME
+ ERROR_ALLOTTED_SPACE_EXCEEDED ETO_NUMERICSLATIN ERROR_DS_ATT_NOT_DEF_IN_SCHEMA
+ ENABLE_AUTO_POSITION ERROR_SIGNAL_REFUSED ERROR_DS_DRS_EXTENSIONS_CHANGED
+ ERROR_IPSEC_IKE_PROCESS_ERR_TRANS ERROR_SXS_XML_E_UNCLOSEDTAG
+ ERROR_DS_AUTH_METHOD_NOT_SUPPORTED ERROR_DS_CANT_CACHE_CLASS
+ ERROR_DS_NAME_ERROR_NOT_UNIQUE ERROR_IPSEC_IKE_CRL_FAILED
+ ERROR_BAD_DESCRIPTOR_FORMAT ERROR_BAD_REM_ADAP ERROR_CLUSTER_RESOURCE_TYPE_NOT_FOUND
+ ERROR_INVALID_THREAD_ID ERROR_DS_NOT_AN_OBJECT ERROR_DS_DRA_OBJ_NC_MISMATCH
+ ERROR_INVALID_EA_NAME ERROR_NOT_QUORUM_CAPABLE EXCEPTION_FLT_STACK_CHECK
+ ERROR_DS_BAD_INSTANCE_TYPE ERROR_CLUSTER_NODE_NOT_READY
+ ERROR_IPSEC_IKE_FAILSSPINIT ERROR_DS_CANT_MOVE_RESOURCE_GROUP
+ ERROR_SMARTCARD_SUBSYSTEM_FAILURE ERROR_CORE_RESOURCE
+ ERROR_INVALID_MEDIA_POOL ERROR_INSTALL_TRANSFORM_FAILURE
+ ERROR_HOOK_NOT_INSTALLED ERROR_SUCCESS_REBOOT_INITIATED
+ ERROR_SXS_XML_E_INVALID_HEXIDECIMAL ERROR_CTX_MODEM_RESPONSE_ERROR
+ ESHUTDOWN ERROR_DS_ATT_SCHEMA_REQ_SYNTAX ERROR_INVALID_PRINTER_COMMAND
+ ERROR_INVALID_FLAG_NUMBER ERROR_PARTIAL_COPY ERROR_IPSEC_IKE_RPC_DELETE
+ ENOLCK ERROR_TRANSFORM_NOT_SUPPORTED EPSPRINTING ERROR_PARAMETER_QUOTA_EXCEEDED
+ ERROR_EVENTLOG_FILE_CHANGED ERROR_WINDOW_NOT_COMBOBOX
+ ERROR_FUNCTION_FAILED EMR_STROKEANDFILLPATH ERROR_IPSEC_IKE_NO_PUBLIC_KEY
+ EXCEPTION_NONCONTINUABLE ERROR_DISK_CORRUPT ERROR_SEM_IS_SET
+ ERROR_DLL_INIT_FAILED EM_GETMARGINS ERROR_INSTALL_SERVICE_FAILURE
+ ERROR_OPLOCK_NOT_GRANTED ERROR_DS_LINK_ID_NOT_AVAILABLE
+ ERROR_DS_SOURCE_AUDITING_NOT_ENABLED EMR_POLYGON ENUMPAPERBINS
+ ERROR_DISK_CHANGE ERROR_INVALID_DWP_HANDLE ERROR_IPSEC_IKE_INVALID_SITUATION
+ EMR_SETBKMODE ERROR_DS_BAD_NAME_SYNTAX ERROR_DS_SUBTREE_NOTIFY_NOT_NC_HEAD
+ ERROR_DS_NO_CHECKPOINT_WITH_PDC ERROR_DS_CANT_DERIVE_SPN_FOR_DELETED_DOMAIN
+ ERROR_CONNECTION_REFUSED ERROR_INSTALL_PACKAGE_REJECTED
+ ERROR_IPSEC_IKE_INVALID_RESPONDER_LIFETIME_NOTIFY ERROR_DS_NO_SUCH_OBJECT
+ ERROR_TOO_MANY_SECRETS ERROR_DS_OUT_OF_SCOPE ERROR_DS_KEY_NOT_UNIQUE
+ EVENTLOG_INFORMATION_TYPE ERROR_BAD_DRIVER ERROR_INSTALL_PACKAGE_VERSION
+ ERROR_IPSEC_IKE_INVALID_HASH_ALG ERROR_BAD_CONFIGURATION
+ ERROR_INVALID_CLEANER ERROR_CLUSTER_NODE_ALREADY_DOWN
+ ERROR_CLUSTER_LOCAL_NODE_NOT_FOUND ERROR_DS_DUP_OID ERROR_HANDLE_EOF
+ ERROR_HOST_NODE_NOT_GROUP_OWNER ERROR_SETCOUNT_ON_BAD_LB
+ ERROR_IPSEC_QM_POLICY_PENDING_DELETION EV_EVENT1 ERROR_CLEANER_SLOT_NOT_SET
+ ERROR_DOWNGRADE_DETECTED ERROR_IPSEC_QM_POLICY_EXISTS ERROR_PIPE_BUSY
+ ERROR_COMMITMENT_LIMIT ERROR_IPSEC_IKE_INVALID_CERT_KEYLEN
+ EXCEPTION_INVALID_HANDLE ERROR_SOURCE_ELEMENT_EMPTY
+ ERROR_PATCH_PACKAGE_OPEN_FAILED ERROR_SXS_XML_E_BADXMLCASE
+ ERROR_DS_AUTHORIZATION_FAILED ESB_ENABLE_BOTH ERROR_SXS_DUPLICATE_ASSEMBLY_NAME
+ ERROR_DS_UNWILLING_TO_PERFORM EMR_ENDPATH ERROR_LOG_FILE_FULL
+ ERROR_TOO_MANY_TCBS ERROR_DS_NO_RESULTS_RETURNED ERROR_NONE_MAPPED
+ ERROR_CTX_CANNOT_MAKE_EVENTLOG_ENTRY ERROR_CONTEXT_EXPIRED
+ ERROR_RESMON_CREATE_FAILED ERROR_SXS_CANT_GEN_ACTCTX
+ ERROR_DS_CANT_ACCESS_REMOTE_PART_OF_AD ERROR_DS_CANT_ADD_ATT_VALUES
+ ETIMEDOUT ERROR_SHARING_PAUSED EXCEPTION_GUARD_PAGE
+ ERROR_CLASS_DOES_NOT_EXIST EXCEPTION_INT_DIVIDE_BY_ZERO
+ ERROR_DS_NAME_ERROR_TRUST_REFERRAL ERROR_CLUSTER_NETINTERFACE_NOT_FOUND
+ ERROR_LISTBOX_ID_NOT_FOUND ERROR_SXS_SECTION_NOT_FOUND EMLINK
+ ERROR_IPSEC_IKE_MM_ACQUIRE_DROP ERROR_INSTALL_NOTUSED
+ ERROR_KEY_HAS_CHILDREN ERROR_DS_DRA_CONNECTION_FAILED
+ ERROR_DS_MUST_BE_RUN_ON_DST_DC ERROR_SXS_XML_E_UNCLOSEDCOMMENT
+ EMR_RESIZEPALETTE E_POINTER ELF_VENDOR_SIZE ERROR_DS_COULDNT_IDENTIFY_OBJECTS_FOR_TREE_DELETE
+ ERROR_DS_CANT_REM_MISSING_ATT ERROR_DS_LOCAL_ERROR ENABLE_INSERT_MODE
+ ERROR_SXS_XML_E_BADSTARTNAMECHAR E_UNEXPECTED ERROR_DS_SECURITY_CHECKING_ERROR
+ ERROR_DS_SRC_SID_EXISTS_IN_FOREST ERROR_PRIVILEGE_NOT_HELD
+ ERROR_UNABLE_TO_INVENTORY_DRIVE EM_POSFROMCHAR ERROR_ALREADY_RUNNING_LKG
+ ERROR_CONTROL_ID_NOT_FOUND EVENTLOG_AUDIT_SUCCESS ERROR_DS_ILLEGAL_SUPERIOR
+ ERROR_CLUSTER_NETINTERFACE_EXISTS ERROR_SXS_VERSION_CONFLICT
+ EMR_PAINTRGN ERROR_SHUTDOWN_CLUSTER ERROR_TOO_MANY_LUIDS_REQUESTED
+ ERROR_DS_INVALID_GROUP_TYPE ERROR_INTERNAL_DB_ERROR
+ EMR_EXCLUDECLIPRECT ERROR_DS_OBJECT_BEING_REMOVED ERROR_IPSEC_DEFAULT_QM_POLICY_NOT_FOUND
+ ERROR_SXS_PROTECTION_PUBLIC_KEY_TOO_SHORT ERROR_DS_OPERATIONS_ERROR
+ ERROR_IPSEC_QM_POLICY_NOT_FOUND ERROR_PATCH_PACKAGE_UNSUPPORTED
+ EC_USEFONTINFO ERROR_NO_MORE_ITEMS EMR_EXTFLOODFILL EWOULDBLOCK
+ ERROR_DEVICE_DOOR_OPEN ERROR_DS_MEMBERSHIP_EVALUATED_LOCALLY
+ ERROR_DS_NO_ATTRIBUTE_OR_VALUE ERROR_IS_SUBST_TARGET EMR_SETBKCOLOR
+ EM_GETSEL ENOMORE ERROR_INSTALL_UI_FAILURE ERROR_BAD_LENGTH
+ ERROR_HOST_NODE_NOT_AVAILABLE ERROR_LIBRARY_OFFLINE
+ ERROR_DS_DS_REQUIRED ENCAPSULATED_POSTSCRIPT ERROR_NO_SYSTEM_MENU
+ ERROR_EMPTY ERROR_DS_CLASS_MUST_BE_CONCRETE ENOTSOCK EV_RXCHAR
+ EC_ENABLEONE ERROR_IOPL_NOT_ENABLED ERROR_DS_CANT_CREATE_IN_NONDOMAIN_NC
+ ERROR_SXS_XML_E_INVALIDATROOTLEVEL ERROR_INVALID_DRIVE
+ ERROR_IPSEC_IKE_POLICY_CHANGE ERROR_CONNECTION_ABORTED
+ ERROR_CLUSTER_NO_RPC_PACKAGES_REGISTERED ERROR_DS_MACHINE_ACCOUNT_QUOTA_EXCEEDED
+ EOPNOTSUPP ERROR_DS_WRONG_LINKED_ATT_SYNTAX ERROR_INTERNAL_ERROR
+ ERROR_DOMAIN_CONTROLLER_NOT_FOUND ERROR_SEM_NOT_FOUND EMR_WIDENPATH
+ ERROR_CONNECTION_COUNT_LIMIT ERROR_DRIVER_BLOCKED EN_UPDATE
+ ERROR_OPERATION_ABORTED ERROR_PRODUCT_VERSION ERROR_DS_CROSS_DOMAIN_CLEANUP_REQD
+ ERROR_LABEL_TOO_LONG ERROR_SERVER_DISABLED ERROR_EFS_SERVER_NOT_TRUSTED
+ ERROR_ADDRESS_ALREADY_ASSOCIATED E_DRAW ERROR_DS_DRA_BAD_INSTANCE_TYPE
+ EXT_DEVICE_CAPS EMR_FILLPATH ERROR_SXS_UNKNOWN_ENCODING_GROUP
+ ERROR_DS_DRA_SCHEMA_INFO_SHIP ERROR_IO_INCOMPLETE ERROR_INVALID_MENU_HANDLE
+ ERROR_DS_SERVER_DOWN ERROR_CLUSTER_NODE_ALREADY_HAS_DFS_ROOT
+ ERROR_CLUSTER_NODE_UP ERROR_DS_WKO_CONTAINER_CANNOT_BE_SPECIAL
+ ERROR_MAGAZINE_NOT_PRESENT ERROR_SXS_ASSEMBLY_NOT_FOUND
+ ERROR_REGISTRY_CORRUPT EMR_LINETO EMR_POLYTEXTOUTW
+ ERROR_IPSEC_IKE_PROCESS_ERR_SIG ERROR_DS_NOT_CLOSEST
+ ERROR_DS_CR_IMPOSSIBLE_TO_VALIDATE_V2 ERROR_HOOK_NEEDS_HMOD
+ ERROR_DS_INVALID_ATTRIBUTE_SYNTAX ERROR_DS_GCVERIFY_ERROR
+ ERROR_DS_NOT_SUPPORTED ERROR_INVALID_SEPARATOR_FILE ERROR_BAD_DEVICE
+ ERROR_PARTITION_FAILURE ERROR_NOT_A_REPARSE_POINT E_INVALIDARG
+ ERROR_DS_DUP_LINK_ID ERROR_SXS_XML_E_UNEXPECTED_WHITESPACE
+ EMR_DELETECOLORSPACE ERROR_IPSEC_IKE_QUEUE_DROP_NO_MM
+ ERROR_RESOURCE_NOT_ONLINE EDEADLK ERROR_DEVICE_REINITIALIZATION_NEEDED
+ ERROR_WMI_GUID_DISCONNECTED EXIT_THREAD_DEBUG_EVENT
+ ERROR_DS_CHILDREN_EXIST ERROR_DS_OBJECT_CLASS_REQUIRED
+ ERROR_LOGON_FAILURE ERROR_DS_FOREST_VERSION_TOO_HIGH
+ ERROR_IPSEC_IKE_QM_DELAY_DROP EM_SETMODIFY ERROR_DS_INSTALL_NO_SCH_VERSION_IN_INIFILE
+ ERROR_DEVICE_NOT_AVAILABLE ERROR_DS_SUB_CLS_TEST_FAIL
+ ERROR_WMI_READ_ONLY ERROR_UNSUPPORTED_TYPE ERROR_MR_MID_NOT_FOUND
+ EM_GETFIRSTVISIBLELINE ELOOP ERROR_BAD_COMMAND ERROR_INVALID_STACKSEG
+ ERROR_DS_COULDNT_LOCK_TREE_FOR_DELETE ERROR_IPSEC_MM_POLICY_EXISTS
+ ERROR_ALL_NODES_NOT_AVAILABLE EMR_POLYGON16 EMR_POLYPOLYLINE
+ EMR_SETROP2 ERROR_ACCESS_DENIED ERROR_CANT_ACCESS_FILE
+ ERROR_IPSEC_IKE_PROCESS_ERR_HASH ERROR_CLUSTER_PROPERTY_DATA_TYPE_MISMATCH
+ ERROR_CLUSTER_RESNAME_NOT_FOUND ERROR_CLUSTER_QUORUMLOG_NOT_FOUND
+ EM_SETHANDLE ERROR_DS_EXISTS_IN_SUB_CLS ENDSESSION_LOGOFF
+ ERROR_DS_CONFIDENTIALITY_REQUIRED ERROR_INVALID_MODULETYPE
+ EM_EMPTYUNDOBUFFER ERROR_IPSEC_IKE_SRVQUERYCRED ERROR_DS_ILLEGAL_BASE_SCHEMA_MOD
+ ERROR_JOIN_TO_SUBST ERROR_DRIVE_MEDIA_MISMATCH ERROR_CTX_MODEM_RESPONSE_NO_DIALTONE
+ ERROR_INVALID_IMPORT_OF_NON_DLL ERROR_IPSEC_MM_FILTER_NOT_FOUND
+ ERROR_DUP_DOMAINNAME ERROR_RMODE_APP ERROR_DS_CANT_RETRIEVE_DN
+ ERROR_IPSEC_IKE_INVALID_HASH_SIZE ERROR_DS_CANT_MOD_PRIMARYGROUPID
+ ERROR_RESMON_INVALID_STATE EC_DISABLE EHOSTDOWN ERROR_BAD_PROVIDER
+ ENOTCONN ERROR_BUFFER_OVERFLOW ESTALE ERROR_IPSEC_IKE_NO_PEER_CERT
+ ERROR_DS_NAME_ERROR_DOMAIN_ONLY ERROR_DS_CANT_DELETE
+ ERROR_DS_INCOMPATIBLE_CONTROLS_USED ERROR_RESOURCE_TYPE_NOT_FOUND
+ EWX_REBOOT ERROR_DS_GLOBAL_CANT_HAVE_UNIVERSAL_MEMBER ERROR_DISCARDED
+ EC_QUERYWAITING ERROR_NO_MATCH ERROR_DS_CANT_RETRIEVE_SD
+ ERROR_LOGON_TYPE_NOT_GRANTED EPERM ERROR_PASSWORD_EXPIRED
+ ERROR_TOO_MANY_SEM_REQUESTS ERROR_DS_NAME_TYPE_UNKNOWN
+ ERROR_REPARSE_TAG_INVALID EMR_ANGLEARC ERROR_MUTUAL_AUTH_FAILED
+ EMR_PLGBLT ERROR_NOT_SAFEBOOT_SERVICE ERROR_FLOPPY_UNKNOWN_ERROR
+ ERROR_EXTENDED_ERROR ERROR_WRITE_PROTECT ERROR_FAILED_SERVICE_CONTROLLER_CONNECT
+ ERROR_SXS_XML_E_INTERNALERROR ERROR_NO_SUPPORTING_DRIVES EM_GETMODIFY
+ ERROR_NO_USER_KEYS ERROR_SXS_XML_E_MISSING_PAREN ERROR_CLUSTER_NODE_SHUTTING_DOWN
+ EN_KILLFOCUS ERROR_SERVICE_MARKED_FOR_DELETE EXCEPTION_DATATYPE_MISALIGNMENT
+ ERROR_TIMEOUT EMR_SETMITERLIMIT ERROR_INVALID_MESSAGEDEST
+ ERROR_EXCL_SEM_ALREADY_OWNED ERROR_DISK_RECALIBRATE_FAILED
+ ERROR_CLUSTER_INVALID_NODE ERROR_ALREADY_WAITING ENHMETA_SIGNATURE
+ ERROR_IPSEC_IKE_OUT_OF_MEMORY ERROR_SERIAL_NO_DEVICE
+ ERROR_IPSEC_TRANSPORT_FILTER_EXISTS ERROR_DS_SRC_DC_MUST_BE_SP4_OR_GREATER
+ ERROR_DS_MASTERDSA_REQUIRED ERROR_IPSEC_IKE_NEGOTIATION_DISABLED
+ ERROR_INVALID_INDEX ERROR_PROFILE_NOT_ASSOCIATED_WITH_DEVICE
+ ERROR_INVALID_EA_HANDLE ERROR_RETRY ERROR_CLEANER_SLOT_SET
+ ERROR_VOLUME_NOT_SUPPORT_EFS ERROR_NO_EFS ERROR_DC_NOT_FOUND
+ ERROR_DLL_NOT_FOUND ERROR_DS_BUSY ERROR_DS_ATT_IS_NOT_ON_OBJ
+ ERROR_PAGEFILE_QUOTA ERROR_DS_NAME_NOT_UNIQUE EMR_SETWINDOWEXTEX
+ ERROR_INVALID_SUB_AUTHORITY ERROR_CLUSTER_LAST_INTERNAL_NETWORK
+ ERROR_CALLBACK_SUPPLIED_INVALID_DATA ERROR_IPSEC_IKE_LOAD_SOFT_SA
+ ERROR_SXS_XML_E_MISSINGQUOTE EMR_SETMAPPERFLAGS ERROR_SXS_MANIFEST_PARSE_ERROR
+ ERROR_SXS_PRIVATE_MANIFEST_CROSS_PATH_WITH_REPARSE_POINT
+ EMR_SELECTCLIPPATH ERROR_SERVICE_NO_THREAD ERROR_MORE_WRITES
+ ENHMETA_STOCK_OBJECT ERROR_NO_MEDIA_IN_DRIVE ERROR_DS_INVALID_DN_SYNTAX
+ ERROR_NO_SUCH_PACKAGE ERROR_SERVICE_EXISTS ERROR_SXS_FILE_HASH_MISMATCH
+ ERROR_INVALID_COLORINDEX ERROR_MAPPED_ALIGNMENT E_ACCESSDENIED
+ ERROR_DS_NONEXISTENT_MAY_HAVE ERROR_RESOURCE_PROPERTIES_STORED
+ ERROR_RESOURCE_PROPERTY_UNCHANGEABLE ERROR_SXS_XML_E_WHITESPACEORQUESTIONMARK
+ ERROR_TRUSTED_RELATIONSHIP_FAILURE EM_FMTLINES ERROR_DS_OBJ_STRING_NAME_EXISTS
+ ERROR_ALREADY_INITIALIZED EMR_POLYPOLYLINE16 ERROR_CANNOT_OPEN_PROFILE
+ ERROR_DS_EXISTS_IN_MUST_HAVE ERROR_UNKNOWN_PRINTER_DRIVER
+ ERROR_DS_ALIASED_OBJ_MISSING ERROR_DS_CROSS_NC_DN_RENAME
+ ERROR_SERVICE_DATABASE_LOCKED ERROR_REPARSE_ATTRIBUTE_CONFLICT
+ ERROR_CLUSTER_CANT_CREATE_DUP_CLUSTER_NAME ERROR_NOT_FOUND
+ ERROR_DS_SRC_GUID_MISMATCH ERROR_BAD_DRIVER_LEVEL EINTR
+ ERROR_DS_CONFIG_PARAM_MISSING ERROR_SEM_USER_LIMIT EMR_EXTTEXTOUTA
+ ERROR_CTX_MODEM_RESPONSE_VOICE EPT_S_NOT_REGISTERED ERROR_FILE_CORRUPT
+ ERROR_SETMARK_DETECTED ERROR_INVALID_DATATYPE ENETUNREACH ECANCELLED
+ ERROR_DS_DOMAIN_RENAME_IN_PROGRESS ERROR_DS_CANT_DEREF_ALIAS
+ ERROR_CHILD_MUST_BE_VOLATILE ERROR_DS_INIT_FAILURE
+ ERROR_IPSEC_IKE_PROCESS_ERR_DELETE ERROR_BAD_PROFILE ENDDOC
+ ERROR_INVALID_PRINTER_NAME ERROR_ALIAS_EXISTS ERROR_BAD_USERNAME
+ EXCEPTION_EXECUTE_HANDLER ERROR_INVALID_HANDLE ERROR_DS_INVALID_LDAP_DISPLAY_NAME
+ ERROR_WMI_SET_FAILURE ERROR_DS_NAME_ERROR_NO_MAPPING
+ ERROR_SERVICE_CANNOT_ACCEPT_CTRL ERROR_SPECIAL_USER
+ ERROR_NODE_CANT_HOST_RESOURCE ERROR_MESSAGE_SYNC_ONLY
+ ERROR_DELETING_ICM_XFORM ETO_GLYPH_INDEX ERROR_INVALID_KEYBOARD_HANDLE
+ ERROR_WMI_DP_FAILED ERROR_BAD_EXE_FORMAT ERROR_DS_MISSING_REQUIRED_ATT
+ EINVALIDPROCTABLE ERROR_DS_DIFFERENT_REPL_EPOCHS EV_RLSD
+ ERROR_DS_EXISTS_IN_AUX_CLS ERROR_TRUST_FAILURE E_HANDLE
+ ERROR_LIBRARY_FULL ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT
+ ERROR_CLUSTER_NETWORK_ALREADY_ONLINE ERROR_LOGIN_WKSTA_RESTRICTION
+ ERROR_FILE_READ_ONLY ERROR_DS_NAME_ERROR_NO_SYNTACTICAL_MAPPING
+ EM_SETREADONLY ERROR_COUNTER_TIMEOUT EMR_CHORD ERROR_SEVERITY_ERROR
+ ERROR_INVALID_SEGMENT_NUMBER ERROR_RESOURCE_NOT_FOUND
+ ERROR_INSTALL_LOG_FAILURE ERROR_DS_BUILD_HIERARCHY_TABLE_FAILED EROFS
+ ERROR_DS_OBJ_CLASS_NOT_DEFINED ERROR_BAD_FORMAT ERROR_INSTALL_USEREXIT
+ ERROR_IPSEC_IKE_LOAD_FAILED EDGE_SUNKEN ERROR_FILE_ENCRYPTED
+ ERROR_BAD_LOGON_SESSION_STATE ERROR_RESOURCE_DISABLED
+ ES_DISPLAY_REQUIRED ERROR_DS_NO_NEST_GLOBALGROUP_IN_MIXEDDOMAIN
+ EMR_SELECTPALETTE ERROR_DS_GC_NOT_AVAILABLE ERROR_ITERATED_DATA_EXCEEDS_64k
+ ERROR_OUT_OF_STRUCTURES ESB_DISABLE_RIGHT ERROR_OBJECT_NOT_FOUND
+ ERROR_DS_CANT_MIX_MASTER_AND_REPS ERROR_DS_ILLEGAL_MOD_OPERATION
+ ERROR_SXS_DUPLICATE_PROGID ERROR_MEMBER_NOT_IN_ALIAS
+ ERROR_PIPE_NOT_CONNECTED ERROR_SXS_UNKNOWN_ENCODING
+ ERROR_ILLEGAL_ELEMENT_ADDRESS ERROR_DS_LOOP_DETECT ERROR_NOT_OWNER
+ ERROR_NOT_JOINED ERROR_NULL_LM_PASSWORD ERROR_REQUEST_ABORTED
+ ERROR_SERVICE_NOT_IN_EXE ERROR_DEPENDENT_SERVICES_RUNNING ENOENT
+ ERROR_CLUSTER_NODE_ALREADY_MEMBER EPROVIDERFAILEDINIT
+ ERROR_PRINTER_NOT_FOUND ERROR_MEMBER_IN_ALIAS ERROR_CANNOT_IMPERSONATE
+ ERROR_FILENAME_EXCED_RANGE ERROR_CTX_PD_NOT_FOUND ERROR_TOO_MANY_OPEN_FILES
+ ERROR_DS_CANT_CACHE_ATT EMR_SETARCDIRECTION ERROR_INVALID_SHARENAME
+ EMSGSIZE ERROR_DS_INSUFF_ACCESS_RIGHTS ERROR_CLASS_ALREADY_EXISTS
+ ERROR_INVALID_PRINTER_STATE ERROR_DISK_FULL ERROR_NO_MORE_SEARCH_HANDLES
+ ERROR_INSTALL_ALREADY_RUNNING ENABLE_WRAP_AT_EOL_OUTPUT
+ ERROR_DS_STRING_SD_CONVERSION_FAILED ERROR_SAME_DRIVE ERROR_DIRECTORY
+ ERROR_CLASS_HAS_WINDOWS EN_CHANGE ERROR_UNKNOWN_FEATURE
+ ERROR_IPSEC_IKE_FAILQUERYSSP ERROR_BAD_TOKEN_TYPE ERROR_DS_CROSS_REF_EXISTS
+ ERROR_SXS_MISSING_ASSEMBLY_IDENTITY_ATTRIBUTE ERROR_RING2_STACK_IN_USE
+ ERROR_CTX_INVALID_WD ERROR_CANNOT_DETECT_PROCESS_ABORT
+ ERROR_IPSEC_IKE_PROCESS_ERR_SA ERROR_MEDIUM_NOT_ACCESSIBLE
+ ERROR_NOT_LOCKED EMR_MOVETOEX ERROR_LAST_ADMIN EMFILE
+ ERROR_NO_MORE_DEVICES EMBDHLP_INPROC_HANDLER ERROR_WMI_ITEMID_NOT_FOUND
+ ERROR_CTX_LOGON_DISABLED ERROR_DS_DRA_MISSING_PARENT
+ ERROR_DS_DRA_EARLIER_SCHEMA_CONFLICT EDGE_ETCHED EMR_POLYLINE
+ ERROR_INVALID_ACCEL_HANDLE ES_AUTOHSCROLL EXCEPTION_ILLEGAL_INSTRUCTION
+ EMR_SETTEXTALIGN ERROR_CLUSTER_NETWORK_HAS_DEPENDENTS ETOOMANYREFS
+ ERROR_NO_LOGON_SERVERS ERROR_SXS_MANIFEST_MISSING_REQUIRED_DEFAULT_NAMESPACE
+ ERROR_INVALID_PRINT_MONITOR ERROR_SPECIAL_GROUP ERROR_DIR_NOT_ROOT
+ ERROR_DS_DUP_MSDS_INTID EMR_SETVIEWPORTORGEX ERROR_OVERRIDE_NOCHANGES
+ ERROR_DS_NONSAFE_SCHEMA_CHANGE ERROR_REDIR_PAUSED ERROR_INVALID_SECURITY_DESCR
+ ERROR_DS_ALIAS_POINTS_TO_ALIAS ERROR_DS_DESTINATION_DOMAIN_NOT_IN_FOREST
+ ECHILD EHOSTUNREACH ERROR_SPOOL_FILE_NOT_FOUND ERROR_NETNAME_DELETED
+ E_FAIL ERROR_PRIVATE_DIALOG_INDEX ERROR_DS_SINGLE_USER_MODE_FAILED
+ ERROR_SERVICE_SPECIFIC_ERROR ERROR_DS_GENERIC_ERROR
+ ERROR_CLUSTER_NETWORK_NOT_FOUND_FOR_IP ERROR_INDEX_ABSENT ENUM_E_LAST
+ ERROR_AUTODATASEG_EXCEEDS_64k ERROR_DS_NAMING_MASTER_GC
+ ERROR_IPSEC_IKE_INVALID_FILTER ERROR_FLOPPY_WRONG_CYLINDER
+ ERROR_REMOTE_STORAGE_NOT_ACTIVE ERROR_DS_DST_NC_MISMATCH
+ ERROR_INVALID_FORM_SIZE ERROR_NO_SCROLLBARS ERROR_BUSY
+ ERROR_DS_INVALID_DMD ERROR_SXS_XML_E_INVALID_UNICODE
+ ERROR_DS_CLIENT_LOOP ERROR_PKINIT_FAILURE ERROR_INVALID_OPERATION
+ ERROR_INVALID_PASSWORDNAME EXDEV ERROR_SXS_XML_E_UNCLOSEDSTRING
+ ERROR_STACK_BUFFER_OVERRUN ERROR_NON_MDICHILD_WINDOW ENUM_S_LAST
+ ERROR_NOT_SUBSTED ERROR_DISK_OPERATION_FAILED ERROR_MEMBER_IN_GROUP
+ ES_CENTER ERROR_IPSEC_IKE_DROP_NO_RESPONSE ERROR_UNKNOWN_PORT
+ EMBDHLP_INPROC_SERVER ERROR_POPUP_ALREADY_ACTIVE EMR_HEADER
+ ERROR_INVALID_DOMAIN_ROLE ES_OEMCONVERT ERROR_DS_NO_PARENT_OBJECT
+ ERROR_JOURNAL_DELETE_IN_PROGRESS ERROR_EXE_MARKED_INVALID
+ ERROR_ACCOUNT_LOCKED_OUT ERROR_INVALID_DATA ERROR_RESOURCE_NOT_AVAILABLE
+ ERROR_DS_UNABLE_TO_SURRENDER_ROLES ERROR_CSCSHARE_OFFLINE
+ ERROR_DOMAIN_TRUST_INCONSISTENT ERROR_DS_SECURITY_ILLEGAL_MODIFY
+ ERROR_IPSEC_IKE_MM_DELAY_DROP ERROR_IPSEC_IKE_PEER_CRL_FAILED
+ ERROR_NO_VOLUME_LABEL ERROR_DS_DRA_PREEMPTED EMR_PIXELFORMAT
+ ERROR_INVALID_NETNAME ERROR_SXS_DUPLICATE_WINDOWCLASS_NAME
+ ERROR_DS_ROOT_MUST_BE_NC ERROR_DS_SENSITIVE_GROUP_VIOLATION
+ ERROR_PRINTER_DRIVER_BLOCKED EV_RING EMR_REALIZEPALETTE
+ ERROR_NOT_SUPPORTED_ON_STANDARD_SERVER ENOMEM ERROR_DS_CANT_DERIVE_SPN_WITHOUT_SERVER_REF
+ ERROR_NETWORK_ACCESS_DENIED EMR_FLATTENPATH ERROR_UNKNOWN_PROPERTY
+ ERROR_ARITHMETIC_OVERFLOW EMR_ARC ERROR_INVALID_LB_MESSAGE
+ ERROR_CURRENT_DOMAIN_NOT_ALLOWED ERROR_IPSEC_TRANSPORT_FILTER_NOT_FOUND
+ ERROR_META_EXPANSION_TOO_LONG ERROR_MENU_ITEM_NOT_FOUND
+ ERROR_CTX_SHADOW_NOT_RUNNING ERROR_TRANSPORT_FULL ERROR_SXS_XML_E_UNCLOSEDDECL
+ ERROR_DS_NAME_UNPARSEABLE ERROR_NOACCESS EISDIR EMR_BEGINPATH
+ ERROR_CLUSTER_NO_SECURITY_CONTEXT EMR_FILLRGN ERROR_PORT_UNREACHABLE
+ ERROR_DS_NO_NEST_LOCALGROUP_IN_MIXEDDOMAIN EXCEPTION_IN_PAGE_ERROR
+ ENABLE_WINDOW_INPUT ERROR_ACCOUNT_DISABLED ERROR_CLUSCFG_ROLLBACK_FAILED
+ ERROR_DS_ALIAS_PROBLEM ERROR_DS_COULDNT_UPDATE_SPNS
+ ERROR_INSTALL_TEMP_UNWRITABLE ERROR_DS_AFFECTS_MULTIPLE_DSAS
+ ERROR_DS_SYNTAX_MISMATCH ERROR_DS_DUP_MAPI_ID ERROR_WMI_ALREADY_DISABLED
+ ERROR_SXS_XML_E_MISSINGSEMICOLON ERROR_DS_NAME_TOO_LONG EMR_POLYDRAW
+ ERROR_DS_DRA_SOURCE_REINSTALLED ERROR_IPSEC_TUNNEL_FILTER_NOT_FOUND
+ ERROR_CTX_WINSTATION_NAME_INVALID ERROR_UNEXP_NET_ERR ENETDOWN
+ ERROR_NO_PROMOTION_ACTIVE ERROR_OUTOFMEMORY ERROR_NETWORK_BUSY
+ ENETRESET ERROR_DS_CANT_MOD_OBJ_CLASS ERROR_IPSEC_IKE_SA_REAPED
+ ERROR_PAGED_SYSTEM_RESOURCES ERROR_INVALID_EVENT_COUNT
+ ERROR_DS_BAD_RDN_ATT_ID_SYNTAX ERROR_CAN_NOT_COMPLETE
+ ERROR_TOO_MANY_MUXWAITERS ERROR_SXS_ACTIVATION_CONTEXT_DISABLED
+ ERROR_SHUTDOWN_IN_PROGRESS EVENT_MODIFY_STATE ERROR_NO_SHUTDOWN_IN_PROGRESS
+ ERROR_IO_DEVICE ERROR_CTX_INVALID_MODEMNAME ERROR_INVALID_USER_BUFFER
+ ERROR_PIPE_LISTENING ERROR_IPSEC_IKE_UNKNOWN_DOI ERROR_EXE_MACHINE_TYPE_MISMATCH
+ ERROR_DS_NO_RIDS_ALLOCATED ERROR_CLUSTER_NODE_EXISTS
+ ERROR_HWNDS_HAVE_DIFF_PARENT ERROR_SEEK ERROR_INVALID_PIXEL_FORMAT
+ ERROR_PATH_NOT_FOUND ERROR_INVALID_EVENTNAME ERROR_DS_MISSING_EXPECTED_ATT
+ ERROR_INVALID_CATEGORY EWX_POWEROFF END_PATH ERROR_DIRECT_ACCESS_HANDLE
+ EV_ERR ERROR_EA_LIST_INCONSISTENT EN_HSCROLL ERROR_CREATE_FAILED
+ ERROR_NO_TRACKING_SERVICE ERROR_SUBST_TO_SUBST ERROR_DS_DRA_GENERIC
+ EMR_SETPOLYFILLMODE ETO_RTLREADING ERROR_CLUSTER_PARAMETER_MISMATCH
+ ERROR_DS_REPLICA_SET_CHANGE_NOT_ALLOWED_ON_DISABLED_CR ES_AUTOVSCROLL
+ ERROR_DEVICE_NOT_CONNECTED ERROR_DS_MODIFYDN_DISALLOWED_BY_FLAG
+ ENABLE_PROCESSED_INPUT ERROR_INSTALL_SOURCE_ABSENT ERROR_IS_SUBSTED
+ ERROR_IPSEC_IKE_ADD_UPDATE_KEY_FAILED ES_NUMBER ERROR_SXS_XML_E_COMMENTSYNTAX
+ ERROR_MEDIA_INCOMPATIBLE EMR_SCALEWINDOWEXTEX EMR_SETBRUSHORGEX
+ EM_GETLIMITTEXT ERROR_INVALID_FIELD ERROR_THREAD_1_INACTIVE
+ ERROR_NOT_ENOUGH_SERVER_MEMORY ERROR_DS_CROSS_DOM_MOVE_ERROR ENOSPC
+ ERROR_SXS_XML_E_EXPECTINGCLOSEQUOTE ERROR_INVALID_REPARSE_DATA
+ ERROR_CTX_SHADOW_DENIED ERROR_NO_DATA_DETECTED EVENTLOG_FORWARDS_READ
+ ERROR_SXS_XML_E_UNEXPECTEDENDTAG ERROR_DATABASE_BACKUP_CORRUPT
+ ES_RIGHT ERROR_DS_CANT_FIND_DC_FOR_SRC_DOMAIN ERROR_SAM_INIT_FAILURE
+ ERROR_DS_NO_CHAINED_EVAL ERROR_SUCCESS_RESTART_REQUIRED
+ ERROR_IPSEC_MM_AUTH_NOT_FOUND ERROR_IRQ_BUSY ERROR_DS_NC_MUST_HAVE_NC_PARENT
+ ERROR_INVALID_WINDOW_HANDLE ERROR_CLUSTER_OLD_VERSION
+ ERROR_INVALID_TABLE ERROR_DS_SHUTTING_DOWN ES_READONLY
+ ERROR_FILE_NOT_ENCRYPTED ERROR_HOST_UNREACHABLE EXCEPTION_MAXIMUM_PARAMETERS
+ ERROR_POTENTIAL_FILE_FOUND ERROR_MEDIA_OFFLINE ERROR_NO_SIGNAL_SENT
+ ERROR_DRIVE_LOCKED EPROCLIM ERROR_WMI_DP_NOT_FOUND ERROR_INVALID_SID
+ ERROR_CLUSTER_WRONG_OS_VERSION ERROR_DS_DRA_SCHEMA_MISMATCH
+ ERROR_CLUSTER_JOIN_ABORTED E2BIG ERROR_DS_RESERVED_LINK_ID EDGE_BUMP
+ ERROR_SXS_PROTECTION_CATALOG_NOT_VALID EV_RXFLAG ERROR_INVALID_STATE
+ ERROR_DS_OBJ_GUID_EXISTS ERROR_UNRECOGNIZED_VOLUME
+ ERROR_HOTKEY_ALREADY_REGISTERED ERROR_NOT_AUTHENTICATED
+ ERROR_SIGNAL_PENDING ERROR_NO_INHERITANCE ERROR_DS_DUP_RDN
+ ERROR_SERVICE_NOT_ACTIVE ERROR_RESOURCE_NOT_PRESENT
+ ERROR_RELOC_CHAIN_XEEDS_SEGLIM ERROR_DS_CR_IMPOSSIBLE_TO_VALIDATE
+ ERROR_DS_SEC_DESC_TOO_SHORT ERROR_BAD_RECOVERY_POLICY
+ ERROR_IPSEC_IKE_PROCESS_ERR_VENDOR EMR_STRETCHDIBITS
+ ERROR_DS_CANT_RETRIEVE_INSTANCE EMR_POLYLINETO ERROR_INVALID_PROFILE
+ ERROR_SHARING_BUFFER_EXCEEDED ELF_VERSION ERROR_DESTINATION_ELEMENT_FULL
+ ERROR_NO_LOG_SPACE EMR_POLYTEXTOUTA ERROR_DS_DOMAIN_VERSION_TOO_HIGH
+ ERROR_KEY_DELETED ERROR_LOCKED ERROR_DS_NTDSCRIPT_SYNTAX_ERROR
+ ERROR_DHCP_ADDRESS_CONFLICT ERROR_DS_ATT_NOT_DEF_FOR_CLASS
+ EM_LINESCROLL ERROR_STATIC_INIT ERROR_DS_GC_REQUIRED
+ ERROR_IPSEC_IKE_NEGOTIATION_PENDING ERROR_CURRENT_DIRECTORY
+ ERROR_SEM_OWNER_DIED EMR_BITBLT ERROR_INSTALL_LANGUAGE_UNSUPPORTED
+ EM_GETLINE ERROR_PROTOCOL_UNREACHABLE ERROR_DS_CLASS_NOT_DSA
+ ERROR_SERVICE_ALREADY_RUNNING EMR_RECTANGLE EREFUSED
+ ERROR_DS_NOT_SUPPORTED_SORT_ORDER ERROR_RESOURCE_DATA_NOT_FOUND
+ ERROR_IPSEC_IKE_INVALID_KEY_USAGE EDGE_RAISED ERROR_APP_WRONG_OS
+ ERROR_ENCRYPTION_FAILED ERROR_PRINTQ_FULL EMR_RESTOREDC
+ ERROR_POLICY_ONLY_IN_DS ERROR_INVALID_EDIT_HEIGHT ERROR_DUPLICATE_TAG
+ ERROR_SXS_XML_E_MISSINGROOT EV_BREAK ERROR_JOURNAL_HOOK_SET EM_SETSEL
+ ERROR_CTX_WINSTATION_ACCESS_DENIED ERROR_DS_MAX_OBJ_SIZE_EXCEEDED
+ EM_LINEINDEX ERROR_CTX_TD_ERROR ENABLEPAIRKERNING ERROR_GLOBAL_ONLY_HOOK
+ ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED ERROR_TIME_SKEW
+ ERROR_PRINT_MONITOR_IN_USE ES_MULTILINE ERROR_ENVVAR_NOT_FOUND
+ EM_REPLACESEL ERROR_TOO_MANY_SIDS ERROR_GENERIC_NOT_MAPPED
+ ERROR_CLUSTER_INVALID_NETWORK EMR_CREATECOLORSPACE
+ ERROR_JOURNAL_ENTRY_DELETED ERROR_UNABLE_TO_INVENTORY_TRANSPORT
+ ERROR_OLD_WIN_VERSION ERROR_CANT_DISABLE_MANDATORY
+ ERROR_SET_POWER_STATE_VETOED ERROR_LM_CROSS_ENCRYPTION_REQUIRED
+ ERROR_INVALID_PRIORITY ERROR_STACK_OVERFLOW ERROR_INVALID_LOGON_TYPE
+ EM_GETPASSWORDCHAR ERROR_UNKNOWN_PRINTPROCESSOR EXIT_SUCCESS
+ ERROR_ACCOUNT_RESTRICTION ERROR_DS_NCNAME_MUST_BE_NC
+ ERROR_DS_DRA_SHUTDOWN ERROR_DS_RANGE_CONSTRAINT EUSERS
+ ERROR_INSTALL_SUSPEND ERROR_TOO_MANY_SEMAPHORES ERROR_DS_NO_REF_DOMAIN
+ ERROR_INVALID_HOOK_FILTER ERROR_CTX_WINSTATION_ALREADY_EXISTS
+ ERROR_SXS_XML_E_INVALIDSWITCH EMR_SETSTRETCHBLTMODE
+ ERROR_NOT_CHILD_WINDOW ERROR_DS_REFERRAL_LIMIT_EXCEEDED
+ ERROR_INVALID_SPI_VALUE ERROR_NOT_EMPTY ERROR_CLUSTER_MEMBERSHIP_INVALID_STATE
+ ENAMETOOLONG ERROR_BAD_USER_PROFILE ERROR_IPSEC_IKE_INVALID_SIGNATURE
+ ENOEXEC ERROR_ALREADY_EXISTS ERROR_JOIN_TO_JOIN ERROR_RESMON_ONLINE_FAILED
+ ERROR_IPSEC_IKE_KERBEROS_ERROR ERROR_INVALID_MEDIA
+ ERROR_CLUSTER_MEMBERSHIP_HALT EMR_POLYBEZIER ERROR_PRINTER_DRIVER_WARNED
+ ERROR_CLUSTERLOG_EXCEEDS_MAXSIZE ERROR_SEM_TIMEOUT
+ ERROR_INVALID_COMPUTERNAME ERROR_ACCOUNT_EXPIRED ERROR_DS_GOVERNSID_MISSING
+ ERROR_IPSEC_IKE_SOFT_SA_TORN_DOWN ERROR_FLOPPY_BAD_REGISTERS
+ ERROR_ACCESS_DISABLED_BY_POLICY EPT_S_INVALID_ENTRY ERROR_NO_TOKEN
+ ERROR_INVALID_DOMAIN_STATE ERROR_DS_CANT_FIND_EXPECTED_NC
+ ERROR_DS_FILTER_UNKNOWN ERROR_NO_QUOTAS_FOR_ACCOUNT
+ ERROR_NONPAGED_SYSTEM_RESOURCES ERROR_LUIDS_EXHAUSTED
+ ERROR_DS_DST_DOMAIN_NOT_NATIVE EVENTLOG_SUCCESS ERROR_DS_AG_CANT_HAVE_UNIVERSAL_MEMBER
+ ERROR_IPSEC_IKE_PROCESS_ERR_CERT ERROR_TRUSTED_DOMAIN_FAILURE
+ ERROR_MAX_THRDS_REACHED ERROR_HOOK_TYPE_NOT_ALLOWED ERROR_HOST_DOWN
+ ERROR_DS_NO_MSDS_INTID ERROR_SERVER_SHUTDOWN_IN_PROGRESS
+ ERROR_DS_INIT_FAILURE_CONSOLE ERROR_NO_RECOVERY_POLICY
+ ERROR_GROUP_NOT_AVAILABLE ERROR_PRINT_MONITOR_ALREADY_INSTALLED
+ ERROR_DUP_NAME ERROR_INSTALL_FAILURE ERROR_DECRYPTION_FAILED
+ ERROR_NO_NETWORK EMR_FRAMERGN E_PENDING ERROR_GROUP_NOT_ONLINE
+ ERROR_NOT_LOGON_PROCESS ERROR_GRACEFUL_DISCONNECT EPROTONOSUPPORT
+ ERROR_CONTROLLING_IEPORT ENABLE_LINE_INPUT ERROR_SXS_UNTRANSLATABLE_HRESULT
+ ERROR_NETWORK_NOT_AVAILABLE ECONNABORTED ERROR_DEPENDENCY_ALREADY_EXISTS
+ ERROR_DS_DRA_REPL_PENDING ERROR_IPSEC_IKE_PROCESS_ERR_NOTIFY
+ ERROR_APPHELP_BLOCK ERROR_DS_CANT_DEMOTE_WITH_WRITEABLE_NC
+ ERROR_BROKEN_PIPE ERROR_INTERNAL_DB_CORRUPTION EMR_EXTTEXTOUTW
+ ERROR_PASSWORD_MUST_CHANGE EMR_MASKBLT ERROR_DS_GROUP_CONVERSION_ERROR
+ ERROR_CLUSTER_JOIN_NOT_IN_PROGRESS ERROR_DS_EPOCH_MISMATCH
+ ERROR_DS_INCOMPATIBLE_VERSION EMR_SETDIBITSTODEVICE
+ ERROR_DS_INSUFFICIENT_ATTR_TO_CREATE_OBJECT ERROR_PRINTER_HAS_JOBS_QUEUED
+ ERROR_DEVICE_ALREADY_REMEMBERED ERROR_KM_DRIVER_BLOCKED
+ ERROR_SERVICE_NEVER_STARTED E_NOTIMPL ERROR_INSTALL_PLATFORM_UNSUPPORTED
+ ERROR_CLUSTER_JOIN_IN_PROGRESS EMR_GLSBOUNDEDRECORD
+ ERROR_INVALID_SERVER_STATE ERROR_CTX_CONSOLE_DISCONNECT
+ ERROR_POLICY_OBJECT_NOT_FOUND EM_LIMITTEXT ERROR_DOMAIN_EXISTS
+ ERROR_SXS_XML_E_UNEXPECTED_STANDALONE ERROR_BAD_PATHNAME
+ ERROR_CANT_DELETE_LAST_ITEM ERROR_SXS_XML_E_XMLDECLSYNTAX
+ EXCEPTION_FLT_INEXACT_RESULT ERROR_BAD_NET_RESP ERROR_LOGON_SESSION_COLLISION
+ ERROR_DS_UNKNOWN_OPERATION EVENT_ALL_ACCESS ERROR_DS_DRA_NO_REPLICA
+ ERROR_HANDLE_DISK_FULL ERROR_NODE_NOT_AVAILABLE ES_SYSTEM_REQUIRED
+ ERROR_CLUSTER_NODE_NOT_MEMBER ERROR_SERVICE_NOT_FOUND
+ ERROR_DS_ALIAS_DEREF_PROBLEM EM_SETPASSWORDCHAR ERROR_BUSY_DRIVE
+ ERROR_REMOTE_STORAGE_MEDIA_ERROR ENOSYS ERROR_IPSEC_IKE_TIMED_OUT
+ ETO_IGNORELANGUAGE ERROR_DS_AUTH_UNKNOWN ERROR_DS_CANT_RETRIEVE_CHILD
+ ERROR_RXACT_COMMIT_FAILURE ERROR_DS_MODIFYDN_DISALLOWED_BY_INSTANCE_TYPE
+ ERROR_DS_RECALCSCHEMA_FAILED ERROR_EAS_DIDNT_FIT ERROR_USER_DELETE_TRUST_QUOTA_EXCEEDED
+ ERROR_CLUSTERLOG_NOT_ENOUGH_SPACE ERROR_NO_SUCH_PRIVILEGE
+ ERROR_PRINTER_DRIVER_IN_USE ESB_DISABLE_UP ERROR_REGISTRY_RECOVERED
+ ERROR_NO_SECURITY_ON_OBJECT ERROR_FUNCTION_NOT_CALLED
+ ERROR_CLUSTER_IPADDR_IN_USE ERROR_DS_SRC_OBJ_NOT_GROUP_OR_USER
+ ERROR_NO_ASSOCIATION ERROR_IPSEC_IKE_MM_LIMIT ERROR_TOO_MANY_CONTEXT_IDS
+ ERROR_INVALID_AT_INTERRUPT_TIME ERROR_CANCEL_VIOLATION
+ ERROR_INVALID_MESSAGENAME ERROR_CTX_WINSTATION_BUSY
+ ERROR_DS_ATT_SCHEMA_REQ_ID ERROR_IPSEC_IKE_QUEUE_DROP_MM
+ ERROR_CLUSCFG_ALREADY_COMMITTED EMR_CREATEMONOBRUSH
+ ERROR_DS_BAD_HIERARCHY_FILE ERROR_DS_SRC_NAME_MISMATCH
+ ERROR_CLUSTER_EVICT_WITHOUT_CLEANUP ERROR_CTX_LICENSE_EXPIRED
+ ERROR_ACTIVATION_COUNT_EXCEEDED ERROR_DS_LOCAL_MEMBER_OF_LOCAL_ONLY
+ ERROR_DS_ATTRIBUTE_TYPE_UNDEFINED ERROR_SXS_XML_E_EXPECTINGTAGEND
+ ERROR_DS_NO_FPO_IN_UNIVERSAL_GROUPS ERROR_SXS_XML_E_UNCLOSEDSTARTTAG
+ ERROR_MEDIA_CHANGED ERROR_DOMAIN_CONTROLLER_EXISTS
+ ERROR_VC_DISCONNECTED ERROR_SWAPERROR ENHANCED_KEY
+ ERROR_RESOURCE_LANG_NOT_FOUND EVENTLOG_ERROR_TYPE ERROR_IPSEC_IKE_DH_FAILURE
+ ERROR_SXS_MANIFEST_INVALID_REQUIRED_DEFAULT_NAMESPACE
+ ERROR_SXS_INVALID_ACTCTXDATA_FORMAT ERROR_DS_DUPLICATE_ID_FOUND
+ ERROR_REMOTE_SESSION_LIMIT_EXCEEDED ERROR_GEN_FAILURE
+ ERROR_DS_DRA_INVALID_PARAMETER ERROR_DS_NOTIFY_FILTER_TOO_COMPLEX
+ ERROR_NOT_CONNECTED EXCEPTION_ARRAY_BOUNDS_EXCEEDED ERROR_EOM_OVERFLOW
+ ERROR_INVALID_MONITOR_HANDLE ERROR_QUORUM_RESOURCE_ONLINE_FAILED
+ EC_RIGHTMARGIN ERROR_RESOURCE_NAME_NOT_FOUND ERROR_WMI_INVALID_REGINFO
+ ERROR_NO_SITENAME ENABLEDUPLEX ERROR_DS_DOMAIN_VERSION_TOO_LOW
+ EXIT_PROCESS_DEBUG_EVENT ERROR_DS_NO_OBJECT_MOVE_IN_SCHEMA_NC
+ EXCEPTION_CONTINUE_EXECUTION EWX_LOGOFF ERROR_MESSAGE_EXCEEDS_MAX_SIZE
+ EMR_STRETCHBLT ERROR_DS_DRA_INCONSISTENT_DIT ERROR_READ_FAULT
+ ERROR_DS_DRA_NOT_SUPPORTED ERROR_DS_NO_CHAINING ERROR_DS_MACHINE_ACCOUNT_CREATED_PRENT4
+ EV_CTS ERROR_DS_NO_BEHAVIOR_VERSION_IN_MIXEDDOMAIN
+ ERROR_SERVER_HAS_OPEN_HANDLES EMR_GDICOMMENT ERROR_SXS_ROOT_MANIFEST_DEPENDENCY_NOT_INSTALLED
+ ERROR_LOCK_FAILED ERROR_NO_IMPERSONATION_TOKEN ERROR_EVENTLOG_CANT_START
+ ERROR_DATABASE_FULL ERROR_DS_NO_PKT_PRIVACY_ON_CONNECTION
+ ERROR_FILE_OFFLINE ERROR_DISK_RESET_FAILED ERROR_ADDRESS_NOT_ASSOCIATED
+ EMR_SETMAPMODE ERROR_DS_BAD_ATT_SCHEMA_SYNTAX EVENTLOG_SEQUENTIAL_READ
+ ENABLE_PROCESSED_OUTPUT ERROR_CONNECTED_OTHER_PASSWORD_DEFAULT
+ ERROR_BAD_PIPE EINVALIDPROVIDER ERROR_PROC_NOT_FOUND
+ ERROR_ALREADY_FIBER ERROR_IPSEC_IKE_NO_CERT ERROR_DS_UNAVAILABLE_CRIT_EXTENSION
+ ERROR_DDE_FAIL ERROR_INVALID_ENVIRONMENT ERROR_DS_COMPARE_FALSE
+ ERROR_CANTWRITE EXIT_FAILURE ERROR_BAD_ENVIRONMENT
+ ERROR_DS_CONSTRAINT_VIOLATION ERROR_EFS_ALG_BLOB_TOO_BIG
+ EMBDHLP_DELAYCREATE ERROR_DS_NOT_ON_BACKLINK ERROR_CLUSTER_NODE_NOT_FOUND
+ ERROR_CLUSTER_INSTANCE_ID_MISMATCH ERROR_WINDOW_NOT_DIALOG
+ ERROR_END_OF_MEDIA ERROR_SUBST_TO_JOIN ERROR_NOT_REGISTRY_FILE
+ ERROR_BAD_VALIDATION_CLASS ERROR_REPARSE_TAG_MISMATCH
+ ERROR_FILE_NOT_FOUND ERROR_DS_DESTINATION_AUDITING_NOT_ENABLED
+ ERROR_INVALID_ID_AUTHORITY EMBDHLP_CREATENOW ERROR_PRODUCT_UNINSTALLED
+ ERROR_METAFILE_NOT_SUPPORTED ERROR_SXS_INVALID_XML_NAMESPACE_URI
+ ERROR_DS_RIDMGR_INIT_ERROR ES_PASSWORD ERROR_DS_DRA_SOURCE_DISABLED
+ EMR_POLYPOLYGON ERROR_POINT_NOT_FOUND ERROR_DS_CROSS_REF_BUSY
+ ERROR_SERVICE_DEPENDENCY_DELETED ERROR_IPSEC_IKE_NOTCBPRIV
+ ERROR_DIR_EFS_DISALLOWED ERROR_DS_CANT_REMOVE_ATT_CACHE
+ ERROR_IPSEC_IKE_PROCESS_ERR_NONCE EREMOTE ERROR_SERVICE_START_HANG
+ ERROR_EAS_NOT_SUPPORTED ERROR_INVALID_MINALLOCSIZE
+ ERROR_MEMBER_NOT_IN_GROUP ERROR_ALREADY_THREAD ERROR_DS_CANT_REPLACE_HIDDEN_REC
+ ERROR_CLUSTER_MISMATCHED_COMPUTER_ACCT_NAME ERROR_CTX_CLIENT_LICENSE_NOT_SET
+ ERROR_DEPENDENT_RESOURCE_EXISTS ERROR_HOST_NODE_NOT_RESOURCE_OWNER
+ ERROR_DS_NAME_REFERENCE_INVALID ERROR_NON_DOMAIN_SID
+ ERROR_DS_OBJ_TOO_LARGE ERROR_DS_DUP_LDAP_DISPLAY_NAME
+ ERROR_DS_ENCODING_ERROR ERROR_WMI_TRY_AGAIN ERROR_SXS_DUPLICATE_TLBID
+ ERROR_CLUSTER_NODE_NOT_PAUSED ERROR_DS_CANT_ADD_SYSTEM_ONLY
+ ERROR_IPSEC_IKE_INVALID_AUTH_ALG ERROR_CAN_NOT_DEL_LOCAL_WINS
+ ERROR_INVALID_FILTER_PROC EEXIST ERROR_DS_CANT_DELETE_DSA_OBJ
+ ERROR_IPSEC_MM_AUTH_EXISTS ERROR_INVALID_OPLOCK_PROTOCOL
+ ERROR_INVALID_COMMAND_LINE EMR_SETICMMODE ERROR_NO_RECOVERY_PROGRAM
+ ERROR_INVALID_HOOK_HANDLE EPT_S_CANT_CREATE ERROR_DS_INTERNAL_FAILURE
+ ERROR_EXCEPTION_IN_SERVICE ERROR_DS_DRA_REF_ALREADY_EXISTS
+ ERROR_CLUSTER_MAXNUM_OF_RESOURCES_EXCEEDED ESRCH ERROR_CLUSTER_INCOMPATIBLE_VERSIONS
+ ERROR_IPSEC_IKE_INVALID_COOKIE EFAULT ERROR_DEVICE_NOT_PARTITIONED
+ ERROR_DS_SEC_DESC_INVALID ERROR_ATOMIC_LOCKS_NOT_SUPPORTED EMR_EOF
+ ERROR_TLW_WITH_WSCHILD ERROR_DS_UNICODEPWD_NOT_IN_QUOTES
+ ERROR_TOO_MANY_NAMES ERROR_CLUSTER_RESTYPE_NOT_SUPPORTED EPROTOTYPE
+ ERROR_DS_GLOBAL_CANT_HAVE_CROSSDOMAIN_MEMBER ERROR_DATABASE_DOES_NOT_EXIST
+ ERROR_DS_ROLE_NOT_VERIFIED EN_MAXTEXT ERROR_INVALID_COMBOBOX_MESSAGE
+ EV_EVENT2 EM_SCROLLCARET ERROR_DS_TIMELIMIT_EXCEEDED
+ ERROR_SPL_NO_STARTDOC ERROR_INVALID_SERVICE_LOCK ERROR_LB_WITHOUT_TABSTOPS
+ EMR_SETMETARGN ERROR_DS_CANT_REM_MISSING_ATT_VAL ERROR_IPSEC_TRANSPORT_FILTER_PENDING_DELETION
+ ERROR_PRINTER_ALREADY_EXISTS ERROR_WINS_INTERNAL ERROR_SXS_XML_E_MISSINGEQUALS
+ ERROR_DS_PROTOCOL_ERROR ERROR_DS_NAMING_VIOLATION ERROR_CLEANER_CARTRIDGE_SPENT
+ EMR_SETCOLORSPACE ERROR_EFS_VERSION_NOT_SUPPORT ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION
+ ERROR_IPSEC_IKE_INVALID_HASH ERROR_CLUSTER_NETWORK_NOT_INTERNAL
+ ERROR_ARENA_TRASHED ERROR_DS_NO_MORE_RIDS ERROR_INVALID_LEVEL ENOTTY
+ ERROR_USER_EXISTS ERROR_DS_ADD_REPLICA_INHIBITED ERROR_INVALID_PRIMARY_GROUP
+ ERROR_DS_DATABASE_ERROR ERROR_CHILD_WINDOW_MENU ERROR_CTX_INVALID_PD
+ ERROR_BEGINNING_OF_MEDIA ERROR_SERVER_NOT_DISABLED
+ ERROR_REDIRECTOR_HAS_OPEN_HANDLES ERROR_INVALID_WORKSTATION
+ ERROR_CANNOT_DETECT_DRIVER_FAILURE EM_UNDO EXCEPTION_FLT_OVERFLOW
+ EMR_POLYLINE16 ERROR_IPSEC_IKE_INVALID_CERT_TYPE ERROR_SXS_XML_E_RESERVEDNAMESPACE
+ ERROR_INVALID_FUNCTION ERROR_NOT_SAME_DEVICE ERROR_INVALID_MSGBOX_STYLE
+ ERROR_NOT_SUPPORTED_ON_SBS ENABLE_MOUSE_INPUT ERROR_CLUSCFG_SYSTEM_DISK_DRIVE_LETTER_CONFLICT
+ ERROR_WAIT_NO_CHILDREN EDOM EMR_ROUNDRECT ERROR_REQ_NOT_ACCEP
+ ERROR_NO_NET_OR_BAD_PATH ERROR_CANNOT_COPY ENABLE_ECHO_INPUT
+ EMR_EXTCREATEFONTINDIRECTW ERROR_INVALID_OWNER ERROR_INVALID_SERVICE_ACCOUNT
+ ERROR_FULL_BACKUP ERROR_MOD_NOT_FOUND ERROR_UNABLE_TO_CLEAN
+ ERROR_SXS_XML_E_UNCLOSEDCDATA ERROR_UNABLE_TO_REMOVE_REPLACED
+ ERROR_DS_SORT_CONTROL_MISSING EM_SETTABSTOPS ERROR_IO_PENDING
+ EMR_SELECTOBJECT EMR_POLYPOLYGON16 ERROR_IPSEC_IKE_UNSUPPORTED_ID
+ ETO_CLIPPED ERROR_UNABLE_TO_UNLOAD_MEDIA ERROR_SXS_DUPLICATE_CLSID
+ ERROR_NO_PROC_SLOTS ERROR_DS_PARENT_IS_AN_ALIAS ERROR_SEVERITY_SUCCESS
+ ERROR_EA_TABLE_FULL EMR_POLYBEZIERTO16 ERROR_LOCAL_USER_SESSION_KEY
+ ERROR_DS_OFFSET_RANGE_ERROR ERROR_RING2SEG_MUST_BE_MOVABLE
+ ERROR_EFS_DISABLED ESB_DISABLE_LTUP ERROR_CANTREAD EMR_SETPIXELV
+ ERROR_REGISTRY_IO_FAILED ERROR_SXS_KEY_NOT_FOUND EMR_SETWINDOWORGEX
+ EVENTLOG_WARNING_TYPE ERROR_SOME_NOT_MAPPED EXCEPTION_DEBUG_EVENT
+ ERROR_INVALID_ACCOUNT_NAME ERROR_BAD_NET_NAME EV_TXEMPTY ES_LOWERCASE
+ EV_PERR EBUSY ERROR_DS_PARAM_ERROR ENUMPAPERMETRICS
+ ERROR_NT_CROSS_ENCRYPTION_REQUIRED ERROR_SHARED_POLICY
+ ERROR_BAD_DEV_TYPE ERROR_CTX_NO_OUTBUF ERROR_PROFILE_NOT_FOUND
+ EWX_FORCE ERROR_INVALID_LIBRARY ERROR_DS_NAME_TOO_MANY_PARTS
+ ERROR_IPSEC_IKE_SECLOADFAIL ERROR_NON_ACCOUNT_SID ERROR_CTX_WINSTATION_NOT_FOUND
+ ERROR_DS_OUT_OF_VERSION_STORE ERROR_QUORUM_OWNER_ALIVE
+ ERROR_IPSEC_IKE_INVALID_ENCRYPT_ALG EVENPARITY ERROR_DS_CANT_FIND_NC_IN_CACHE
+ ERROR_SXS_XML_E_BADCHARDATA ERROR_NO_SUCH_MEMBER EXCEPTION_SINGLE_STEP
+ ERROR_UNABLE_TO_LOCK_MEDIA ERROR_SUCCESS ERROR_INVALID_LOGON_HOURS
+ ENOTEMPTY ERROR_INVALID_TRANSFORM ERROR_DS_ATT_VAL_ALREADY_EXISTS
+ ERROR_ACTIVE_CONNECTIONS EVENTLOG_AUDIT_FAILURE ERROR_PRINT_CANCELLED
+ ERROR_INVALID_NAME ERROR_LOGON_SESSION_EXISTS ERROR_INVALID_WINDOW_STYLE
+ EPT_S_CANT_PERFORM_OP ERROR_DS_DRA_NAME_COLLISION EXCEPTION_PRIV_INSTRUCTION
+ ERROR_CLUSTER_NODE_UNREACHABLE ERROR_SHARING_VIOLATION
+ ESB_DISABLE_BOTH ERROR_BAD_THREADID_ADDR ERROR_SERVICE_DEPENDENCY_FAIL
+ EMR_ELLIPSE ERROR_LOCK_VIOLATION ERROR_INVALID_GW_COMMAND
+ ERROR_CANT_EVICT_ACTIVE_NODE EM_SETRECTNP ERROR_COLORSPACE_MISMATCH
+ ERROR_DS_CANT_WITH_ACCT_GROUP_MEMBERSHPS ERROR_DEPENDENCY_NOT_ALLOWED
+ ERROR_DS_EXISTS_IN_RDNATTID ERROR_DS_COULDNT_CONTACT_FSMO
+ ERROR_DS_DRA_RPC_CANCELLED ERROR_UNABLE_TO_INVENTORY_SLOT
+ ERROR_DS_OBJ_CLASS_NOT_SUBCLASS ERROR_REG_NAT_CONSUMPTION
+ ERROR_DS_NON_BASE_SEARCH ERROR_CANTOPEN ERROR_DS_NOT_INSTALLED
+ ERROR_CLUSTERLOG_CORRUPT ERROR_BAD_QUERY_SYNTAX ERROR_IPSEC_IKE_DH_FAIL
+ EFBIG EMR_ARCTO ERROR_BAD_IMPERSONATION_LEVEL ECONNRESET
+ ERROR_CLUSTER_SHUTTING_DOWN ERROR_NESTING_NOT_ALLOWED
+ ERROR_WORKING_SET_QUOTA ERROR_INVALID_PASSWORD ERROR_PROCESS_ABORTED
+ ERROR_FILE_EXISTS ERROR_TOO_MANY_POSTS ERROR_HOTKEY_NOT_REGISTERED
+ ERROR_SERVICE_DOES_NOT_EXIST EMR_STROKEPATH ES_USER_PRESENT
+ ERROR_DS_SCHEMA_ALLOC_FAILED ERROR_DS_ADMIN_LIMIT_EXCEEDED
+ ERROR_NEGATIVE_SEEK EMR_EXTSELECTCLIPRGN ERROR_REC_NON_EXISTENT
+ EXCEPTION_FLT_INVALID_OPERATION EINPROGRESS ERROR_DS_CANT_START
+ EADDRNOTAVAIL ERROR_IS_JOINED EMR_POLYLINETO16 ERROR_DS_NO_RDN_DEFINED_IN_SCHEMA
+ EMR_CREATEPEN ENUM_ALL_CALENDARS ERROR_REQUEST_REFUSED
+ ERROR_DS_ATT_ALREADY_EXISTS ERROR_NO_UNICODE_TRANSLATION
+ EVENTLOG_BACKWARDS_READ ERROR_DOMAIN_LIMIT_EXCEEDED
+ EMR_SETWORLDTRANSFORM ERROR_DS_RDN_DOESNT_MATCH_SCHEMA
+ ERROR_ADAP_HDW_ERR ERROR_OBJECT_ALREADY_EXISTS ERROR_WINDOW_OF_OTHER_THREAD
+ ESPIPE ERROR_CANT_OPEN_ANONYMOUS ERROR_DS_INSTALL_NO_SRC_SCH_VERSION
+ EM_GETLINECOUNT EALREADY ERROR_INVALID_FORM_NAME ERROR_MORE_DATA
+ ERROR_IPSEC_MM_FILTER_EXISTS ERROR_CHILD_NOT_COMPLETE
+ ERROR_NOT_ENOUGH_MEMORY ERROR_JOURNAL_NOT_ACTIVE ERROR_IPSEC_IKE_INVALID_GROUP
+ ERROR_CTX_LICENSE_NOT_AVAILABLE ERROR_DS_DRA_MAIL_PROBLEM
+ ERROR_DS_BACKLINK_WITHOUT_LINK ERROR_DEPENDENCY_NOT_FOUND
+ ERROR_DS_SAM_INIT_FAILURE ERROR_SERVICE_REQUEST_TIMEOUT
+ ERROR_INVALID_FLAGS ERROR_EA_FILE_CORRUPT ERROR_DESTROY_OBJECT_OF_OTHER_THREAD
+ ERROR_DS_ROOT_CANT_BE_SUBREF ERROR_PATCH_PACKAGE_INVALID
+ ERROR_QUORUM_RESOURCE ERROR_BADKEY ERROR_WRONG_DISK
+ ERROR_INVALID_SERVICE_CONTROL ERROR_DS_HIERARCHY_TABLE_MALLOC_FAILED
+ ERROR_LOGIN_TIME_RESTRICTION ERROR_SERVICE_LOGON_FAILED
+ ERROR_DS_SEMANTIC_ATT_TEST EPS_SIGNATURE ERROR_PIPE_CONNECTED
+ ERROR_SET_POWER_STATE_FAILED EDEADLOCK ERROR_NOT_LOGGED_ON
+ EMR_SETPALETTEENTRIES ERROR_INVALID_GROUP_ATTRIBUTES
+ ERROR_INVALID_MESSAGE ERROR_TOKEN_ALREADY_IN_USE ERROR_UNRECOGNIZED_MEDIA
+ ERROR_INVALID_TARGET_HANDLE ERROR_IPSEC_IKE_ATTRIB_FAIL
+ ERROR_DS_DRA_DB_ERROR ERROR_EXE_CANNOT_MODIFY_STRONG_SIGNED_BINARY
+ ERROR_DS_DRA_SCHEMA_CONFLICT EXTTEXTOUT ERROR_TOO_MANY_MODULES
+ ERROR_QUORUMLOG_OPEN_FAILED ERROR_INC_BACKUP ERROR_DS_DUP_SCHEMA_ID_GUID
+ ERROR_DS_CANT_REMOVE_CLASS_CACHE ERROR_RECOVERY_FAILURE
+ ERROR_INVALID_MEMBER ERROR_SXS_XML_E_UNEXPECTEDEOF
+ ERROR_CTX_SHADOW_INVALID ERROR_DS_UNAVAILABLE EMR_INTERSECTCLIPRECT
+ ERROR_SXS_XML_E_BADCHARINSTRING EM_SETLIMITTEXT ERROR_SXS_DUPLICATE_DLL_NAME
+ ERROR_NOT_READY ERROR_IPSEC_QM_POLICY_IN_USE ERROR_IPSEC_IKE_GENERAL_PROCESSING_ERROR
+ EMR_POLYBEZIER16 ERROR_CLUSTER_SYSTEM_CONFIG_CHANGED
+ ERROR_IPSEC_IKE_AUTH_FAIL ERROR_TOO_MANY_CMDS ERROR_NO_SUCH_USER
+ EM_GETHANDLE ERROR_NO_SUCH_LOGON_SESSION ERROR_DS_DRA_ACCESS_DENIED
+ ERROR_DS_INVALID_SCRIPT ENUM_S_FIRST ERROR_CTX_SHADOW_ENDED_BY_MODE_CHANGE
+ ERROR_DS_CANT_ADD_TO_GC ERROR_SXS_PROCESS_DEFAULT_ALREADY_SET
+ ERROR_WMI_ALREADY_ENABLED ERROR_CLUSTER_NETWORK_NOT_FOUND
+ ERROR_SXS_PROTECTION_RECOVERY_FAILED ERROR_INVALID_CMM
+ ERROR_SXS_DUPLICATE_IID ES_LEFT ERROR_DS_NONEXISTENT_MUST_HAVE
+ ERROR_DS_DECODING_ERROR ERROR_NO_SUCH_DOMAIN ERROR_IPSEC_IKE_DECRYPT
+ ERROR_OPEN_FILES ERROR_SPL_NO_ADDJOB ERROR_IPSEC_IKE_NO_MM_POLICY
+ ERROR_DS_NAME_ERROR_RESOLVING ERROR_SXS_XML_E_MULTIPLE_COLONS
+ EM_SCROLL ERROR_SXS_XML_E_DUPLICATEATTRIBUTE ERROR_SXS_XML_E_INVALIDENCODING
+ ERROR_CONNECTED_OTHER_PASSWORD ERROR_DS_NAME_ERROR_NOT_FOUND
+ EN_VSCROLL ERROR_DS_FOREST_VERSION_TOO_LOW ENOFILE
+ ERROR_CLUSTER_NETWORK_ALREADY_OFFLINE ERROR_UNABLE_TO_EJECT_MOUNTED_MEDIA
+ ERROR_BAD_NETPATH ERROR_ONLY_IF_CONNECTED ERROR_FLOPPY_ID_MARK_NOT_FOUND
+ ERROR_DS_CANT_DEL_MASTER_CROSSREF EM_LINELENGTH ERROR_NO_SUCH_ALIAS
+ ERROR_UNABLE_TO_MOVE_REPLACEMENT_2 ERROR_SXS_XML_E_INCOMPLETE_ENCODING
+ ERROR_DS_DRA_ABANDON_SYNC ERROR_WMI_SERVER_UNAVAILABLE
+ ERROR_INSTALL_PACKAGE_OPEN_FAILED ERROR_NO_MORE_USER_HANDLES
+ ETO_NUMERICSLOCAL ERROR_INVALID_ADDRESS ERROR_DS_DRA_REF_NOT_FOUND
+ EXCEPTION_FLT_DIVIDE_BY_ZERO ES_NOHIDESEL ERROR_SECRET_TOO_LONG
+ ERROR_DS_CANT_MOVE_APP_QUERY_GROUP ERROR_IPSEC_TUNNEL_FILTER_PENDING_DELETION
+ ERROR_INSUFFICIENT_BUFFER EM_SETWORDBREAKPROC ERROR_BAD_UNIT
+ ERROR_IPSEC_IKE_GETSPIFAIL ERROR_DS_CANT_FIND_DSA_OBJ
+ ERROR_CTX_MODEM_RESPONSE_BUSY ERROR_DS_DSA_MUST_BE_INT_MASTER
+ EM_CHARFROMPOS ERROR_DS_EXISTING_AD_CHILD_NC ERROR_INVALID_ORDINAL
+ ERROR_IPSEC_MM_AUTH_PENDING_DELETION ERROR_FAIL_I24
+ ERROR_DS_ILLEGAL_XDOM_MOVE_OPERATION ERROR_NO_SYSTEM_RESOURCES
+ ERROR_DS_REFERRAL ERROR_INVALID_BLOCK ENABLE_EXTENDED_FLAGS
+ ERROR_CLUSTER_GUM_NOT_LOCKER ERROR_NET_WRITE_FAULT EN_ERRSPACE
+ ERROR_CONNECTION_INVALID ERROR_RPL_NOT_ALLOWED ENXIO
+ ERROR_DS_NAME_VALUE_TOO_LONG EASTEUROPE_CHARSET ERROR_DS_INCORRECT_ROLE_OWNER
+ ERROR_GROUP_EXISTS ERROR_DS_AUX_CLS_TEST_FAIL ERROR_DYNLINK_FROM_INVALID_RING
+ ERROR_NO_TRUST_LSA_SECRET ERROR_VOLUME_NOT_SIS_ENABLED
+ ERROR_REM_NOT_LIST ERROR_WRITE_FAULT ERROR_WMI_INVALID_MOF
+ ERROR_INVALID_VERIFY_SWITCH ERROR_INVALID_GROUPNAME
+ ERROR_ALREADY_REGISTERED ERROR_DS_SAM_NEED_BOOTKEY_PASSWORD
+ ES_UPPERCASE ERROR_INVALID_SHOWWIN_COMMAND ERROR_DS_NOT_AUTHORITIVE_FOR_DST_NC
+ ERROR_DS_CANT_CREATE_UNDER_SCHEMA ERROR_IPSEC_IKE_INVALID_SIG
+ ERROR_NETWORK_UNREACHABLE ERROR_CALL_NOT_IMPLEMENTED
+ ERROR_SXS_XML_E_MULTIPLEROOTS EMR_PIE ERROR_POSSIBLE_DEADLOCK
+ ERROR_SCREEN_ALREADY_LOCKED ERROR_SXS_XML_E_UNBALANCEDPAREN
+ ERROR_DS_DRA_EXTN_CONNECTION_FAILED ERROR_FULLSCREEN_MODE
+ ERROR_LICENSE_QUOTA_EXCEEDED ERROR_DEV_NOT_EXIST ERROR_WMI_GUID_NOT_FOUND
+ ERROR_INVALID_CURSOR_HANDLE ERROR_SESSION_CREDENTIAL_CONFLICT
+ ERROR_DS_LOW_DSA_VERSION EADDRINUSE EC_ENABLEALL ERROR_DS_INAPPROPRIATE_MATCHING
+ EXCEPTION_STACK_OVERFLOW ERROR_DS_NONEXISTENT_POSS_SUP
+ ERROR_IPSEC_MM_POLICY_IN_USE EBADF ERROR_DS_USER_BUFFER_TO_SMALL
+ ERROR_DS_FILTER_USES_CONTRUCTED_ATTRS ERROR_DATATYPE_MISMATCH
+ EXCEPTION_CONTINUE_SEARCH EWX_SHUTDOWN EXCEPTION_INT_OVERFLOW
+ ERROR_WMI_INSTANCE_NOT_FOUND ERROR_CTX_CONSOLE_CONNECT
+ ERROR_NO_BROWSER_SERVERS_FOUND ERROR_DS_NC_STILL_HAS_DSAS
+ EXCEPTION_ACCESS_VIOLATION ERROR_DS_INVALID_NAME_FOR_SPN
+ ERROR_DS_ATTRIBUTE_OR_VALUE_EXISTS ERROR_INVALID_ICON_HANDLE
+ ERROR_INSTALL_TRANSFORM_REJECTED ERROR_CTX_BAD_VIDEO_MODE
+ ERROR_CONTINUE ECONNREFUSED ERROR_CTX_MODEM_RESPONSE_NO_CARRIER
+ EMR_GLSRECORD ERROR_DS_DRA_BAD_NC ERROR_NOT_ENOUGH_QUOTA
+ ERROR_SXS_POLICY_PARSE_ERROR EDISCON ERROR_INVALID_LIST_FORMAT
+ ERROR_SERVICE_DISABLED ERROR_IPSEC_IKE_SRVACQFAIL EM_CANUNDO
+ ERROR_INVALID_SERVICENAME ERROR_INVALID_ACCESS ERROR_INVALID_BLOCK_LENGTH
+ ERROR_DS_SINGLE_VALUE_CONSTRAINT ERROR_IPSEC_IKE_PROCESS_ERR_CERT_REQ
+ ERROR_NO_SPOOL_SPACE ERROR_IPSEC_IKE_ERROR EMR_DELETEOBJECT
+ ERROR_CANNOT_FIND_WND_CLASS ERROR_DS_SAM_INIT_FAILURE_CONSOLE
+ ERROR_DS_MODIFYDN_WRONG_GRANDPARENT ERROR_PROMOTION_ACTIVE
+ ERROR_FILEMARK_DETECTED ERROR_IPSEC_IKE_NEG_STATUS_END EV_RX80FULL
+ ERROR_IPSEC_IKE_PROCESS_ERR_PROP ERROR_INSTALL_PACKAGE_INVALID
+ ENUM_E_FIRST ERROR_NO_USER_SESSION_KEY ERROR_DS_SIZELIMIT_EXCEEDED
+ ERROR_DS_INAPPROPRIATE_AUTH ERROR_SECTOR_NOT_FOUND EDESTADDRREQ
+ ERROR_DS_UNKNOWN_ERROR ERANGE ERROR_SXS_WRONG_SECTION_TYPE
+ ERROR_CTX_SHADOW_DISABLED ERROR_IPSEC_IKE_BENIGN_REINIT
+ EXCEPTION_NONCONTINUABLE_EXCEPTION ENABLERELATIVEWIDTHS
+ ERROR_TAG_NOT_PRESENT ERROR_CTX_MODEM_INF_NOT_FOUND
+ ERROR_DS_DRA_SOURCE_IS_PARTIAL_REPLICA ERROR_INVALID_DOMAINNAME EILSEQ
+ ERROR_DS_OBJECT_RESULTS_TOO_LARGE ERROR_WRONG_PASSWORD
+ ERROR_UNKNOWN_REVISION ERROR_ILL_FORMED_PASSWORD ERROR_DISK_TOO_FRAGMENTED
+ EPIPE ERROR_INVALID_DRIVE_OBJECT ERROR_PER_USER_TRUST_QUOTA_EXCEEDED
+ ERROR_UNKNOWN_PRINT_MONITOR ERROR_SXS_INVALID_ASSEMBLY_IDENTITY_ATTRIBUTE
+ ERROR_DS_STRONG_AUTH_REQUIRED EMR_MODIFYWORLDTRANSFORM
+ ERROR_CTX_MODEM_RESPONSE_TIMEOUT ESB_DISABLE_DOWN ERROR_CTX_CLOSE_PENDING
+ ERROR_SXS_XML_E_BADNAMECHAR ERROR_UNKNOWN_COMPONENT
+ ERROR_IPSEC_IKE_SA_DELETED ERROR_DS_MISSING_SUPREF
+ ERROR_DS_REMOTE_CROSSREF_OP_FAILED EM_SETMARGINS ERROR_DS_MISSING_FSMO_SETTINGS
+ EVENTLOG_SEEK_READ ERROR_SEVERITY_INFORMATIONAL ERROR_IPSEC_IKE_PROCESS_ERR_ID
+ ERROR_DS_CANT_ON_NON_LEAF ERROR_DS_NO_DELETED_NAME
+ ERROR_IPSEC_IKE_INVALID_PAYLOAD ERROR_DS_DRA_OUT_OF_MEM
+ ERROR_CANCELLED ELF_CULTURE_LATIN ERROR_ALL_USER_TRUST_QUOTA_EXCEEDED
+ ERROR_INVALID_HANDLE_STATE ERROR_PATCH_TARGET_NOT_FOUND
+ ERROR_DS_DRA_OBJ_IS_REP_SOURCE ERROR_INVALID_DLL ERROR_DS_NO_TREE_DELETE_ABOVE_NC
+ ERROR_DEBUGGER_INACTIVE ERROR_BOOT_ALREADY_ACCEPTED
+ EMR_SETCOLORADJUSTMENT ERROR_CLUSTERLOG_RECORD_EXCEEDS_MAXSIZE
+ ERROR_CIRCULAR_DEPENDENCY ERROR_CLUSTER_NODE_PAUSED
+ ERROR_PATCH_PACKAGE_REJECTED EC_LEFTMARGIN EMR_EXTCREATEPEN
+ ERROR_WMI_UNRESOLVED_INSTANCE_REF EV_DSR ERROR_INFLOOP_IN_RELOC_CHAIN
+ ERROR_DS_CANT_ON_RDN EAGAIN ERROR_DS_SRC_AND_DST_OBJECT_CLASS_MISMATCH
+ ENOPROTOOPT ERROR_CLUSTER_NODE_DOWN ERROR_PASSWORD_RESTRICTION
+ ERROR_ACCESS_DISABLED_WEBBLADE ERROR_DS_DRA_BAD_DN
+ ERROR_CLUSTER_NODE_ALREADY_UP ERROR_DS_DRA_INTERNAL_ERROR
+ ERROR_SXS_MANIFEST_FORMAT_ERROR ES_CONTINUOUS ERROR_DS_REPLICATOR_ONLY
+ ERROR_RESOURCE_FAILED ERROR_DS_DRA_DN_EXISTS ERROR_TOO_MANY_SESS
+ ERROR_CLUSTER_INVALID_NETWORK_PROVIDER ERROR_TAG_NOT_FOUND
+ ERROR_SXS_XML_E_UNCLOSEDENDTAG ERROR_UNEXPECTED_OMID
+ ERROR_REVISION_MISMATCH EMR_POLYBEZIERTO ENFILE ERROR_SEEK_ON_DEVICE
+ ERROR_WRONG_EFS EMR_POLYDRAW16 ERROR_NETLOGON_NOT_STARTED
+ ERROR_DS_LOCAL_CANT_HAVE_CROSSDOMAIN_LOCAL_MEMBER ERROR_SUCCESS_REBOOT_REQUIRED
+ ENOTDIR ERROR_CTX_WD_NOT_FOUND EINVAL ERROR_CLUSTER_OWNER_NOT_IN_PREFLIST
+ EMR_CLOSEFIGURE ERROR_IPSEC_MM_POLICY_NOT_FOUND ERROR_MEDIA_NOT_AVAILABLE
+ ERROR_SXS_XML_E_MISSINGWHITESPACE EMR_SCALEVIEWPORTEXTEX
+ ERROR_IPSEC_IKE_PROCESS_ERR ERROR_DS_DRA_BUSY ERROR_DS_REFUSING_FSMO_ROLES
+ ERROR_SXS_THREAD_QUERIES_DISABLED EXCEPTION_BREAKPOINT ERROR_CRC
+ ERROR_IPSEC_IKE_QM_ACQUIRE_DROP ERROR_CLIPPING_NOT_SUPPORTED
+ ERROR_QUORUM_DISK_NOT_FOUND EM_GETTHUMB ERROR_INVALID_SCROLLBAR_RANGE
+ ERROR_UNABLE_TO_LOAD_MEDIUM ERROR_DS_MISSING_INFRASTRUCTURE_CONTAINER
+ ERROR_DS_SRC_AND_DST_NC_IDENTICAL ERROR_INSTALL_REMOTE_DISALLOWED
+ ERROR_IPSEC_DEFAULT_MM_POLICY_NOT_FOUND ERROR_SXS_INVALID_ASSEMBLY_IDENTITY_ATTRIBUTE_NAME
+ ERROR_MACHINE_LOCKED ERROR_NOT_ALL_ASSIGNED EPFNOSUPPORT
+ ERROR_UNABLE_TO_MOVE_REPLACEMENT ERROR_CONNECTION_UNAVAIL
+ ERROR_IPSEC_IKE_POLICY_MATCH EMR_SETVIEWPORTEXTEX ERROR_IPSEC_MM_FILTER_PENDING_DELETION
+ EXCEPTION_FLT_UNDERFLOW ERROR_SEVERITY_WARNING ERROR_SXS_XML_E_BADPEREFINSUBSET
+ ERROR_UNKNOWN_PRODUCT ERROR_DS_INSTALL_SCHEMA_MISMATCH
+ ERROR_IPSEC_IKE_ENCRYPT EM_GETRECT ERROR_MEDIA_UNAVAILABLE
+ ERROR_EVENTLOG_FILE_CORRUPT EMR_ABORTPATH ERROR_DS_DNS_LOOKUP_FAILURE
+ ERROR_DS_CANT_RETRIEVE_ATTS ERROR_DS_NO_REQUESTED_ATTS_FOUND
+ ERROR_DS_TREE_DELETE_NOT_FINISHED ERROR_INCORRECT_ADDRESS ENOBUFS
+ EMR_CREATEPALETTE ERROR_DS_WRONG_OM_OBJ_CLASS ERROR_DS_SCHEMA_UPDATE_DISALLOWED
+ ERROR_SCOPE_NOT_FOUND ERROR_BAD_ARGUMENTS ERROR_NO_WILDCARD_CHARACTERS
+ ES_WANTRETURN ERROR_NOT_CONTAINER ERROR_DS_GLOBAL_CANT_HAVE_LOCAL_MEMBER
+ ERROR_RXACT_INVALID_STATE ERROR_DS_SCHEMA_NOT_LOADED
+ ERROR_DS_SOURCE_DOMAIN_IN_FOREST ERROR_ALREADY_ASSIGNED
+ ERROR_DS_ATTRIBUTE_OWNED_BY_SAM E_ABORT EDQUOT ERROR_SXS_LEAF_MANIFEST_DEPENDENCY_NOT_INSTALLED
+ ERROR_IPSEC_IKE_PROCESS_ERR_KE ERROR_DS_NCNAME_MISSING_CR_REF
+ ERROR_INVALID_EXE_SIGNATURE ERROR_DS_IS_LEAF ERROR_INVALID_ACL
+ ERROR_DS_CANT_MOVE_APP_BASIC_GROUP ERROR_CTX_GRAPHICS_INVALID
+ ERROR_DEVICE_REQUIRES_CLEANING EM_SETRECT EACCES ERROR_CANT_ACCESS_DOMAIN_INFO
+ EMR_OFFSETCLIPRGN ERROR_EXE_CANNOT_MODIFY_SIGNED_BINARY
+ EXCEPTION_FLT_DENORMAL_OPERAND ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT
+ ERROR_DS_INVALID_ROLE_OWNER ERROR_DATABASE_FAILURE
+ ERROR_INVALID_PARAMETER E_OUTOFMEMORY ENUM_CURRENT_SETTINGS
+ ERROR_NO_VOLUME_ID ERROR_INVALID_OPERATION_ON_QUORUM EMR_INVERTRGN
+ ERROR_NO_MORE_FILES ERROR_IPSEC_MM_POLICY_PENDING_DELETION
+ ERROR_CLIPBOARD_NOT_OPEN ERROR_DS_EXISTS_IN_POSS_SUP
+ ERROR_FILE_INVALID ERROR_DS_OBJ_NOT_FOUND ESOCKTNOSUPPORT
+ ERROR_NOLOGON_SERVER_TRUST_ACCOUNT ERROR_DS_INVALID_SEARCH_FLAG
+ ERROR_NO_SUCH_GROUP ENODEV ERROR_IS_JOIN_TARGET ERROR_INSTALL_REMOTE_PROHIBITED
+ ERROR_NOT_EXPORT_FORMAT ERROR_CANNOT_MAKE ERROR_TOO_MANY_LINKS
+ ERROR_GROUP_NOT_FOUND ERROR_DS_CONTROL_NOT_FOUND ERROR_DS_DRA_INCOMPATIBLE_PARTIAL_SET
+ ERROR_DS_NO_CROSSREF_FOR_NC ERROR_EA_ACCESS_DENIED
+ ERROR_MEMBERS_PRIMARY_GROUP);
+
+%EXPORT_TAGS = (
+ POSIX => [qw(
+ E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY
+ EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK
+ EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH
+ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
+ EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS
+ ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTCONN
+ ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT
+ EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE EROFS
+ ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS
+ EUSERS EWOULDBLOCK EXDEV
+ )]
+);
+
+sub ENUM_REGISTRY_SETTINGS () { -2 }
+sub EXCEPTION_CONTINUE_EXECUTION () { -1 }
+sub ENUM_ALL_CALENDARS () { -1 }
+sub ENUM_CURRENT_SETTINGS () { -1 }
+sub ERROR () { 0 }
+sub ESB_ENABLE_BOTH () { 0 }
+sub EMBDHLP_INPROC_HANDLER () { 0 }
+sub ELF_VERSION () { 0 }
+sub EXIT_SUCCESS () { 0 }
+sub EVENTLOG_SUCCESS () { 0 }
+sub EWX_LOGOFF () { 0 }
+sub EMBDHLP_CREATENOW () { 0 }
+sub ERROR_SEVERITY_SUCCESS () { 0 }
+sub ERROR_SUCCESS () { 0 }
+sub ES_LEFT () { 0 }
+sub EC_ENABLEALL () { 0 }
+sub EXCEPTION_CONTINUE_SEARCH () { 0 }
+sub ELF_CULTURE_LATIN () { 0 }
+sub ESB_DISABLE_LEFT () { 1 }
+sub EXCEPTION_NONCONTINUABLE () { 1 }
+sub EV_RXCHAR () { 1 }
+sub EPERM () { 1 }
+sub EXCEPTION_EXECUTE_HANDLER () { 1 }
+sub ES_CENTER () { 1 }
+sub EMBDHLP_INPROC_SERVER () { 1 }
+sub EMR_HEADER () { 1 }
+sub ENABLE_PROCESSED_INPUT () { 1 }
+sub ES_SYSTEM_REQUIRED () { 1 }
+sub ESB_DISABLE_UP () { 1 }
+sub EVENTLOG_ERROR_TYPE () { 1 }
+sub EVENTLOG_SEQUENTIAL_READ () { 1 }
+sub ENABLE_PROCESSED_OUTPUT () { 1 }
+sub EXIT_FAILURE () { 1 }
+sub ERROR_INVALID_FUNCTION () { 1 }
+sub ESB_DISABLE_LTUP () { 1 }
+sub EXCEPTION_DEBUG_EVENT () { 1 }
+sub EWX_SHUTDOWN () { 1 }
+sub EC_LEFTMARGIN () { 1 }
+sub ETO_OPAQUE () { 2 }
+sub ESB_DISABLE_RTDN () { 2 }
+sub EWX_REBOOT () { 2 }
+sub EC_QUERYWAITING () { 2 }
+sub ES_DISPLAY_REQUIRED () { 2 }
+sub ESB_DISABLE_RIGHT () { 2 }
+sub ENOENT () { 2 }
+sub ENABLE_WRAP_AT_EOL_OUTPUT () { 2 }
+sub EVENT_MODIFY_STATE () { 2 }
+sub ES_RIGHT () { 2 }
+sub EV_RXFLAG () { 2 }
+sub EMR_POLYBEZIER () { 2 }
+sub ENABLE_LINE_INPUT () { 2 }
+sub EC_RIGHTMARGIN () { 2 }
+sub ERROR_FILE_NOT_FOUND () { 2 }
+sub EVENTLOG_WARNING_TYPE () { 2 }
+sub EVENPARITY () { 2 }
+sub ENOFILE () { 2 }
+sub ESB_DISABLE_DOWN () { 2 }
+sub EVENTLOG_SEEK_READ () { 2 }
+sub EMR_POLYGON () { 3 }
+sub ERROR_PATH_NOT_FOUND () { 3 }
+sub ESRCH () { 3 }
+sub ESB_DISABLE_BOTH () { 3 }
+sub EVENTLOG_INFORMATION_TYPE () { 4 }
+sub ELF_VENDOR_SIZE () { 4 }
+sub EXIT_THREAD_DEBUG_EVENT () { 4 }
+sub EINTR () { 4 }
+sub ERROR_TOO_MANY_OPEN_FILES () { 4 }
+sub EMR_POLYLINE () { 4 }
+sub EVENTLOG_FORWARDS_READ () { 4 }
+sub ES_MULTILINE () { 4 }
+sub ENABLE_ECHO_INPUT () { 4 }
+sub ETO_CLIPPED () { 4 }
+sub EV_TXEMPTY () { 4 }
+sub EWX_FORCE () { 4 }
+sub ES_USER_PRESENT () { 4 }
+sub EIO () { 5 }
+sub ERROR_ACCESS_DENIED () { 5 }
+sub EDGE_RAISED () { 5 }
+sub EXIT_PROCESS_DEBUG_EVENT () { 5 }
+sub EMR_POLYBEZIERTO () { 5 }
+sub ERROR_INVALID_HANDLE () { 6 }
+sub EDGE_ETCHED () { 6 }
+sub EMR_POLYLINETO () { 6 }
+sub ENXIO () { 6 }
+sub EMR_POLYPOLYLINE () { 7 }
+sub E2BIG () { 7 }
+sub ERROR_ARENA_TRASHED () { 7 }
+sub EVENTLOG_AUDIT_SUCCESS () { 8 }
+sub EC_DISABLE () { 8 }
+sub ENABLE_WINDOW_INPUT () { 8 }
+sub EWX_POWEROFF () { 8 }
+sub ENOEXEC () { 8 }
+sub EV_CTS () { 8 }
+sub EMR_POLYPOLYGON () { 8 }
+sub EVENTLOG_BACKWARDS_READ () { 8 }
+sub ERROR_NOT_ENOUGH_MEMORY () { 8 }
+sub ES_UPPERCASE () { 8 }
+sub EMR_SETWINDOWEXTEX () { 9 }
+sub EDGE_BUMP () { 9 }
+sub ERROR_INVALID_BLOCK () { 9 }
+sub EBADF () { 9 }
+sub EDGE_SUNKEN () { 10 }
+sub ECHILD () { 10 }
+sub ERROR_BAD_ENVIRONMENT () { 10 }
+sub EMR_SETWINDOWORGEX () { 10 }
+sub ENDDOC () { 11 }
+sub ERROR_BAD_FORMAT () { 11 }
+sub EAGAIN () { 11 }
+sub EMR_SETVIEWPORTEXTEX () { 11 }
+sub EMR_SETVIEWPORTORGEX () { 12 }
+sub ENOMEM () { 12 }
+sub ERROR_INVALID_ACCESS () { 12 }
+sub ERROR_INVALID_DATA () { 13 }
+sub EMR_SETBRUSHORGEX () { 13 }
+sub EACCES () { 13 }
+sub ERROR_OUTOFMEMORY () { 14 }
+sub EFAULT () { 14 }
+sub EMR_EOF () { 14 }
+sub ERROR_INVALID_DRIVE () { 15 }
+sub EXCEPTION_MAXIMUM_PARAMETERS () { 15 }
+sub EMR_SETPIXELV () { 15 }
+sub EMR_SETMAPPERFLAGS () { 16 }
+sub ETO_GLYPH_INDEX () { 16 }
+sub ERROR_CURRENT_DIRECTORY () { 16 }
+sub ENABLE_MOUSE_INPUT () { 16 }
+sub ES_LOWERCASE () { 16 }
+sub EBUSY () { 16 }
+sub EVENTLOG_AUDIT_FAILURE () { 16 }
+sub EV_DSR () { 16 }
+sub EMR_SETMAPMODE () { 17 }
+sub EEXIST () { 17 }
+sub ERROR_NOT_SAME_DEVICE () { 17 }
+sub EMR_SETBKMODE () { 18 }
+sub EXDEV () { 18 }
+sub ERROR_NO_MORE_FILES () { 18 }
+sub ERROR_WRITE_PROTECT () { 19 }
+sub EMR_SETPOLYFILLMODE () { 19 }
+sub ENODEV () { 19 }
+sub EMR_SETROP2 () { 20 }
+sub ERROR_BAD_UNIT () { 20 }
+sub ENOTDIR () { 20 }
+sub EISDIR () { 21 }
+sub EMR_SETSTRETCHBLTMODE () { 21 }
+sub ERROR_NOT_READY () { 21 }
+sub ERROR_BAD_COMMAND () { 22 }
+sub EMR_SETTEXTALIGN () { 22 }
+sub EINVAL () { 22 }
+sub EMR_SETCOLORADJUSTMENT () { 23 }
+sub ENFILE () { 23 }
+sub ERROR_CRC () { 23 }
+sub EMR_SETTEXTCOLOR () { 24 }
+sub ERROR_BAD_LENGTH () { 24 }
+sub EMFILE () { 24 }
+sub EMR_SETBKCOLOR () { 25 }
+sub ERROR_SEEK () { 25 }
+sub ENOTTY () { 25 }
+sub ERROR_NOT_DOS_DISK () { 26 }
+sub EMR_OFFSETCLIPRGN () { 26 }
+sub EMR_MOVETOEX () { 27 }
+sub EFBIG () { 27 }
+sub ERROR_SECTOR_NOT_FOUND () { 27 }
+sub ERROR_OUT_OF_PAPER () { 28 }
+sub ENOSPC () { 28 }
+sub ENABLEDUPLEX () { 28 }
+sub EMR_SETMETARGN () { 28 }
+sub EMR_EXCLUDECLIPRECT () { 29 }
+sub ESPIPE () { 29 }
+sub ERROR_WRITE_FAULT () { 29 }
+sub EROFS () { 30 }
+sub ERROR_READ_FAULT () { 30 }
+sub EMR_INTERSECTCLIPRECT () { 30 }
+sub ENUMPAPERBINS () { 31 }
+sub EMLINK () { 31 }
+sub ERROR_GEN_FAILURE () { 31 }
+sub EMR_SCALEVIEWPORTEXTEX () { 31 }
+sub ENABLE_INSERT_MODE () { 32 }
+sub EV_RLSD () { 32 }
+sub EMR_SCALEWINDOWEXTEX () { 32 }
+sub ES_PASSWORD () { 32 }
+sub ERROR_SHARING_VIOLATION () { 32 }
+sub EPIPE () { 32 }
+sub EMR_SAVEDC () { 33 }
+sub EPSPRINTING () { 33 }
+sub EDOM () { 33 }
+sub ERROR_LOCK_VIOLATION () { 33 }
+sub EMR_RESTOREDC () { 34 }
+sub ENUMPAPERMETRICS () { 34 }
+sub ERROR_WRONG_DISK () { 34 }
+sub ERANGE () { 34 }
+sub EMR_SETWORLDTRANSFORM () { 35 }
+sub EDEADLK () { 36 }
+sub ERROR_SHARING_BUFFER_EXCEEDED () { 36 }
+sub EDEADLOCK () { 36 }
+sub EMR_MODIFYWORLDTRANSFORM () { 36 }
+sub EMR_SELECTOBJECT () { 37 }
+sub ERROR_HANDLE_EOF () { 38 }
+sub ENAMETOOLONG () { 38 }
+sub EMR_CREATEPEN () { 38 }
+sub EMR_CREATEBRUSHINDIRECT () { 39 }
+sub ENOLCK () { 39 }
+sub ERROR_HANDLE_DISK_FULL () { 39 }
+sub ENOSYS () { 40 }
+sub EMR_DELETEOBJECT () { 40 }
+sub EMR_ANGLEARC () { 41 }
+sub ENOTEMPTY () { 41 }
+sub EMR_ELLIPSE () { 42 }
+sub EILSEQ () { 42 }
+sub EMR_RECTANGLE () { 43 }
+sub EMR_ROUNDRECT () { 44 }
+sub EMR_ARC () { 45 }
+sub EMR_CHORD () { 46 }
+sub EMR_PIE () { 47 }
+sub EMR_SELECTPALETTE () { 48 }
+sub EMR_CREATEPALETTE () { 49 }
+sub ERROR_NOT_SUPPORTED () { 50 }
+sub EMR_SETPALETTEENTRIES () { 50 }
+sub EMR_RESIZEPALETTE () { 51 }
+sub ERROR_REM_NOT_LIST () { 51 }
+sub EMR_REALIZEPALETTE () { 52 }
+sub ERROR_DUP_NAME () { 52 }
+sub EMR_EXTFLOODFILL () { 53 }
+sub ERROR_BAD_NETPATH () { 53 }
+sub EMR_LINETO () { 54 }
+sub ERROR_NETWORK_BUSY () { 54 }
+sub EMR_ARCTO () { 55 }
+sub ERROR_DEV_NOT_EXIST () { 55 }
+sub EMR_POLYDRAW () { 56 }
+sub ERROR_TOO_MANY_CMDS () { 56 }
+sub EMR_SETARCDIRECTION () { 57 }
+sub ERROR_ADAP_HDW_ERR () { 57 }
+sub EMR_SETMITERLIMIT () { 58 }
+sub ERROR_BAD_NET_RESP () { 58 }
+sub EMR_BEGINPATH () { 59 }
+sub ERROR_UNEXP_NET_ERR () { 59 }
+sub ERROR_BAD_REM_ADAP () { 60 }
+sub EMR_ENDPATH () { 60 }
+sub ERROR_PRINTQ_FULL () { 61 }
+sub EMR_CLOSEFIGURE () { 61 }
+sub EMR_FILLPATH () { 62 }
+sub ERROR_NO_SPOOL_SPACE () { 62 }
+sub EMR_STROKEANDFILLPATH () { 63 }
+sub ERROR_PRINT_CANCELLED () { 63 }
+sub ENABLE_QUICK_EDIT_MODE () { 64 }
+sub ERROR_NETNAME_DELETED () { 64 }
+sub ES_AUTOVSCROLL () { 64 }
+sub EV_BREAK () { 64 }
+sub EMR_STROKEPATH () { 64 }
+sub ERROR_NETWORK_ACCESS_DENIED () { 65 }
+sub EMR_FLATTENPATH () { 65 }
+sub EMR_WIDENPATH () { 66 }
+sub ERROR_BAD_DEV_TYPE () { 66 }
+sub EMR_SELECTCLIPPATH () { 67 }
+sub ERROR_BAD_NET_NAME () { 67 }
+sub ERROR_TOO_MANY_NAMES () { 68 }
+sub EMR_ABORTPATH () { 68 }
+sub ERROR_TOO_MANY_SESS () { 69 }
+sub ERROR_SHARING_PAUSED () { 70 }
+sub EMR_GDICOMMENT () { 70 }
+sub EMR_FILLRGN () { 71 }
+sub ERROR_REQ_NOT_ACCEP () { 71 }
+sub ERROR_REDIR_PAUSED () { 72 }
+sub EMR_FRAMERGN () { 72 }
+sub EMR_INVERTRGN () { 73 }
+sub EMR_PAINTRGN () { 74 }
+sub EMR_EXTSELECTCLIPRGN () { 75 }
+sub EMR_BITBLT () { 76 }
+sub EMR_STRETCHBLT () { 77 }
+sub EMR_MASKBLT () { 78 }
+sub EMR_PLGBLT () { 79 }
+sub EMR_SETDIBITSTODEVICE () { 80 }
+sub ERROR_FILE_EXISTS () { 80 }
+sub EMR_STRETCHDIBITS () { 81 }
+sub EMR_EXTCREATEFONTINDIRECTW () { 82 }
+sub ERROR_CANNOT_MAKE () { 82 }
+sub EMR_EXTTEXTOUTA () { 83 }
+sub ERROR_FAIL_I24 () { 83 }
+sub ERROR_OUT_OF_STRUCTURES () { 84 }
+sub EMR_EXTTEXTOUTW () { 84 }
+sub EMR_POLYBEZIER16 () { 85 }
+sub ERROR_ALREADY_ASSIGNED () { 85 }
+sub EMR_POLYGON16 () { 86 }
+sub ERROR_INVALID_PASSWORD () { 86 }
+sub EMR_POLYLINE16 () { 87 }
+sub ERROR_INVALID_PARAMETER () { 87 }
+sub EMR_POLYBEZIERTO16 () { 88 }
+sub ERROR_NET_WRITE_FAULT () { 88 }
+sub ERROR_NO_PROC_SLOTS () { 89 }
+sub EMR_POLYLINETO16 () { 89 }
+sub EMR_POLYPOLYLINE16 () { 90 }
+sub EMR_POLYPOLYGON16 () { 91 }
+sub EMR_POLYDRAW16 () { 92 }
+sub EMR_CREATEMONOBRUSH () { 93 }
+sub EMR_CREATEDIBPATTERNBRUSHPT () { 94 }
+sub EMR_EXTCREATEPEN () { 95 }
+sub EMR_POLYTEXTOUTA () { 96 }
+sub EMR_POLYTEXTOUTW () { 97 }
+sub EMR_SETICMMODE () { 98 }
+sub EMR_CREATECOLORSPACE () { 99 }
+sub ERROR_TOO_MANY_SEMAPHORES () { 100 }
+sub EMR_SETCOLORSPACE () { 100 }
+sub EMR_DELETECOLORSPACE () { 101 }
+sub ERROR_EXCL_SEM_ALREADY_OWNED () { 101 }
+sub ERROR_SEM_IS_SET () { 102 }
+sub EMR_GLSRECORD () { 102 }
+sub ERROR_TOO_MANY_SEM_REQUESTS () { 103 }
+sub EMR_GLSBOUNDEDRECORD () { 103 }
+sub EMR_PIXELFORMAT () { 104 }
+sub ERROR_INVALID_AT_INTERRUPT_TIME () { 104 }
+sub ERROR_SEM_OWNER_DIED () { 105 }
+sub ERROR_SEM_USER_LIMIT () { 106 }
+sub ERROR_DISK_CHANGE () { 107 }
+sub ERROR_DRIVE_LOCKED () { 108 }
+sub ERROR_BROKEN_PIPE () { 109 }
+sub ERROR_OPEN_FAILED () { 110 }
+sub ERROR_BUFFER_OVERFLOW () { 111 }
+sub ERROR_DISK_FULL () { 112 }
+sub ERROR_NO_MORE_SEARCH_HANDLES () { 113 }
+sub ERROR_INVALID_TARGET_HANDLE () { 114 }
+sub ERROR_INVALID_CATEGORY () { 117 }
+sub ERROR_INVALID_VERIFY_SWITCH () { 118 }
+sub ERROR_BAD_DRIVER_LEVEL () { 119 }
+sub ERROR_CALL_NOT_IMPLEMENTED () { 120 }
+sub ERROR_SEM_TIMEOUT () { 121 }
+sub ERROR_INSUFFICIENT_BUFFER () { 122 }
+sub ERROR_INVALID_NAME () { 123 }
+sub ERROR_INVALID_LEVEL () { 124 }
+sub ERROR_NO_VOLUME_LABEL () { 125 }
+sub ERROR_MOD_NOT_FOUND () { 126 }
+sub ERROR_PROC_NOT_FOUND () { 127 }
+sub EC_ENABLEONE () { 128 }
+sub ES_AUTOHSCROLL () { 128 }
+sub EV_ERR () { 128 }
+sub ETO_RTLREADING () { 128 }
+sub ERROR_WAIT_NO_CHILDREN () { 128 }
+sub ENABLE_EXTENDED_FLAGS () { 128 }
+sub ERROR_CHILD_NOT_COMPLETE () { 129 }
+sub ERROR_DIRECT_ACCESS_HANDLE () { 130 }
+sub ERROR_NEGATIVE_SEEK () { 131 }
+sub ERROR_SEEK_ON_DEVICE () { 132 }
+sub ERROR_IS_JOIN_TARGET () { 133 }
+sub ERROR_IS_JOINED () { 134 }
+sub ERROR_IS_SUBSTED () { 135 }
+sub ERROR_NOT_JOINED () { 136 }
+sub ERROR_NOT_SUBSTED () { 137 }
+sub ERROR_JOIN_TO_JOIN () { 138 }
+sub ERROR_SUBST_TO_SUBST () { 139 }
+sub ERROR_JOIN_TO_SUBST () { 140 }
+sub ERROR_SUBST_TO_JOIN () { 141 }
+sub ERROR_BUSY_DRIVE () { 142 }
+sub ERROR_SAME_DRIVE () { 143 }
+sub ERROR_DIR_NOT_ROOT () { 144 }
+sub ERROR_DIR_NOT_EMPTY () { 145 }
+sub ERROR_IS_SUBST_PATH () { 146 }
+sub ERROR_IS_JOIN_PATH () { 147 }
+sub ERROR_PATH_BUSY () { 148 }
+sub ERROR_IS_SUBST_TARGET () { 149 }
+sub ERROR_SYSTEM_TRACE () { 150 }
+sub ERROR_INVALID_EVENT_COUNT () { 151 }
+sub ERROR_TOO_MANY_MUXWAITERS () { 152 }
+sub ERROR_INVALID_LIST_FORMAT () { 153 }
+sub ERROR_LABEL_TOO_LONG () { 154 }
+sub ERROR_TOO_MANY_TCBS () { 155 }
+sub ERROR_SIGNAL_REFUSED () { 156 }
+sub ERROR_DISCARDED () { 157 }
+sub ERROR_NOT_LOCKED () { 158 }
+sub ERROR_BAD_THREADID_ADDR () { 159 }
+sub ERROR_BAD_ARGUMENTS () { 160 }
+sub ERROR_BAD_PATHNAME () { 161 }
+sub ERROR_SIGNAL_PENDING () { 162 }
+sub ERROR_MAX_THRDS_REACHED () { 164 }
+sub ERROR_LOCK_FAILED () { 167 }
+sub ERROR_BUSY () { 170 }
+sub ERROR_CANCEL_VIOLATION () { 173 }
+sub ERROR_ATOMIC_LOCKS_NOT_SUPPORTED () { 174 }
+sub EM_GETSEL () { 176 }
+sub EM_SETSEL () { 177 }
+sub EM_GETRECT () { 178 }
+sub EM_SETRECT () { 179 }
+sub ERROR_INVALID_SEGMENT_NUMBER () { 180 }
+sub EM_SETRECTNP () { 180 }
+sub EM_SCROLL () { 181 }
+sub EM_LINESCROLL () { 182 }
+sub ERROR_INVALID_ORDINAL () { 182 }
+sub ERROR_ALREADY_EXISTS () { 183 }
+sub EM_SCROLLCARET () { 183 }
+sub EM_GETMODIFY () { 184 }
+sub EM_SETMODIFY () { 185 }
+sub ERROR_INVALID_FLAG_NUMBER () { 186 }
+sub EM_GETLINECOUNT () { 186 }
+sub ERROR_SEM_NOT_FOUND () { 187 }
+sub EM_LINEINDEX () { 187 }
+sub ERROR_INVALID_STARTING_CODESEG () { 188 }
+sub EM_SETHANDLE () { 188 }
+sub ERROR_INVALID_STACKSEG () { 189 }
+sub EM_GETHANDLE () { 189 }
+sub ERROR_INVALID_MODULETYPE () { 190 }
+sub EM_GETTHUMB () { 190 }
+sub ERROR_INVALID_EXE_SIGNATURE () { 191 }
+sub ERROR_EXE_MARKED_INVALID () { 192 }
+sub ERROR_BAD_EXE_FORMAT () { 193 }
+sub EM_LINELENGTH () { 193 }
+sub ERROR_ITERATED_DATA_EXCEEDS_64k () { 194 }
+sub EM_REPLACESEL () { 194 }
+sub ERROR_INVALID_MINALLOCSIZE () { 195 }
+sub EM_GETLINE () { 196 }
+sub ERROR_DYNLINK_FROM_INVALID_RING () { 196 }
+sub ERROR_IOPL_NOT_ENABLED () { 197 }
+sub EM_LIMITTEXT () { 197 }
+sub EM_SETLIMITTEXT () { 197 }
+sub ERROR_INVALID_SEGDPL () { 198 }
+sub EM_CANUNDO () { 198 }
+sub ERROR_AUTODATASEG_EXCEEDS_64k () { 199 }
+sub EM_UNDO () { 199 }
+sub EM_FMTLINES () { 200 }
+sub ERROR_RING2SEG_MUST_BE_MOVABLE () { 200 }
+sub EM_LINEFROMCHAR () { 201 }
+sub ERROR_RELOC_CHAIN_XEEDS_SEGLIM () { 201 }
+sub ERROR_INFLOOP_IN_RELOC_CHAIN () { 202 }
+sub ERROR_ENVVAR_NOT_FOUND () { 203 }
+sub EM_SETTABSTOPS () { 203 }
+sub EM_SETPASSWORDCHAR () { 204 }
+sub EM_EMPTYUNDOBUFFER () { 205 }
+sub ERROR_NO_SIGNAL_SENT () { 205 }
+sub EM_GETFIRSTVISIBLELINE () { 206 }
+sub ERROR_FILENAME_EXCED_RANGE () { 206 }
+sub EM_SETREADONLY () { 207 }
+sub ERROR_RING2_STACK_IN_USE () { 207 }
+sub ERROR_META_EXPANSION_TOO_LONG () { 208 }
+sub EM_SETWORDBREAKPROC () { 208 }
+sub EM_GETWORDBREAKPROC () { 209 }
+sub ERROR_INVALID_SIGNAL_NUMBER () { 209 }
+sub ERROR_THREAD_1_INACTIVE () { 210 }
+sub EM_GETPASSWORDCHAR () { 210 }
+sub EM_SETMARGINS () { 211 }
+sub EM_GETMARGINS () { 212 }
+sub ERROR_LOCKED () { 212 }
+sub EM_GETLIMITTEXT () { 213 }
+sub EM_POSFROMCHAR () { 214 }
+sub ERROR_TOO_MANY_MODULES () { 214 }
+sub ERROR_NESTING_NOT_ALLOWED () { 215 }
+sub EM_CHARFROMPOS () { 215 }
+sub ERROR_EXE_MACHINE_TYPE_MISMATCH () { 216 }
+sub ERROR_EXE_CANNOT_MODIFY_SIGNED_BINARY () { 217 }
+sub ERROR_EXE_CANNOT_MODIFY_STRONG_SIGNED_BINARY () { 218 }
+sub ERROR_BAD_PIPE () { 230 }
+sub ERROR_PIPE_BUSY () { 231 }
+sub ERROR_NO_DATA () { 232 }
+sub ERROR_PIPE_NOT_CONNECTED () { 233 }
+sub ERROR_MORE_DATA () { 234 }
+sub EASTEUROPE_CHARSET () { 238 }
+sub ERROR_VC_DISCONNECTED () { 240 }
+sub ERROR_INVALID_EA_NAME () { 254 }
+sub ERROR_EA_LIST_INCONSISTENT () { 255 }
+sub EN_SETFOCUS () { 256 }
+sub ENABLE_AUTO_POSITION () { 256 }
+sub EV_RING () { 256 }
+sub ENHANCED_KEY () { 256 }
+sub ES_NOHIDESEL () { 256 }
+sub ERROR_NO_MORE_ITEMS () { 259 }
+sub ERROR_CANNOT_COPY () { 266 }
+sub ERROR_DIRECTORY () { 267 }
+sub ERROR_EAS_DIDNT_FIT () { 275 }
+sub ERROR_EA_FILE_CORRUPT () { 276 }
+sub ERROR_EA_TABLE_FULL () { 277 }
+sub ERROR_INVALID_EA_HANDLE () { 278 }
+sub ERROR_EAS_NOT_SUPPORTED () { 282 }
+sub ERROR_NOT_OWNER () { 288 }
+sub ERROR_TOO_MANY_POSTS () { 298 }
+sub ERROR_PARTIAL_COPY () { 299 }
+sub ERROR_OPLOCK_NOT_GRANTED () { 300 }
+sub ERROR_INVALID_OPLOCK_PROTOCOL () { 301 }
+sub ERROR_DISK_TOO_FRAGMENTED () { 302 }
+sub ERROR_DELETE_PENDING () { 303 }
+sub ERROR_MR_MID_NOT_FOUND () { 317 }
+sub ERROR_SCOPE_NOT_FOUND () { 318 }
+sub ERROR_INVALID_ADDRESS () { 487 }
+sub EN_KILLFOCUS () { 512 }
+sub EV_PERR () { 512 }
+sub EXTTEXTOUT () { 512 }
+sub ERROR_ARITHMETIC_OVERFLOW () { 534 }
+sub ERROR_PIPE_CONNECTED () { 535 }
+sub ERROR_PIPE_LISTENING () { 536 }
+sub EN_CHANGE () { 768 }
+sub ENABLERELATIVEWIDTHS () { 768 }
+sub ENABLEPAIRKERNING () { 769 }
+sub ERROR_EA_ACCESS_DENIED () { 994 }
+sub ERROR_OPERATION_ABORTED () { 995 }
+sub ERROR_IO_INCOMPLETE () { 996 }
+sub ERROR_IO_PENDING () { 997 }
+sub ERROR_NOACCESS () { 998 }
+sub ERROR_SWAPERROR () { 999 }
+sub ERROR_STACK_OVERFLOW () { 1001 }
+sub ERROR_INVALID_MESSAGE () { 1002 }
+sub ERROR_CAN_NOT_COMPLETE () { 1003 }
+sub ERROR_INVALID_FLAGS () { 1004 }
+sub ERROR_UNRECOGNIZED_VOLUME () { 1005 }
+sub ERROR_FILE_INVALID () { 1006 }
+sub ERROR_FULLSCREEN_MODE () { 1007 }
+sub ERROR_NO_TOKEN () { 1008 }
+sub ERROR_BADDB () { 1009 }
+sub ERROR_BADKEY () { 1010 }
+sub ERROR_CANTOPEN () { 1011 }
+sub ERROR_CANTREAD () { 1012 }
+sub ERROR_CANTWRITE () { 1013 }
+sub ERROR_REGISTRY_RECOVERED () { 1014 }
+sub ERROR_REGISTRY_CORRUPT () { 1015 }
+sub ERROR_REGISTRY_IO_FAILED () { 1016 }
+sub ERROR_NOT_REGISTRY_FILE () { 1017 }
+sub ERROR_KEY_DELETED () { 1018 }
+sub ERROR_NO_LOG_SPACE () { 1019 }
+sub ERROR_KEY_HAS_CHILDREN () { 1020 }
+sub ERROR_CHILD_MUST_BE_VOLATILE () { 1021 }
+sub ERROR_NOTIFY_ENUM_DIR () { 1022 }
+sub EN_UPDATE () { 1024 }
+sub ES_OEMCONVERT () { 1024 }
+sub ETO_NUMERICSLOCAL () { 1024 }
+sub EV_RX80FULL () { 1024 }
+sub ERROR_DEPENDENT_SERVICES_RUNNING () { 1051 }
+sub ERROR_INVALID_SERVICE_CONTROL () { 1052 }
+sub ERROR_SERVICE_REQUEST_TIMEOUT () { 1053 }
+sub ERROR_SERVICE_NO_THREAD () { 1054 }
+sub ERROR_SERVICE_DATABASE_LOCKED () { 1055 }
+sub ERROR_SERVICE_ALREADY_RUNNING () { 1056 }
+sub ERROR_INVALID_SERVICE_ACCOUNT () { 1057 }
+sub ERROR_SERVICE_DISABLED () { 1058 }
+sub ERROR_CIRCULAR_DEPENDENCY () { 1059 }
+sub ERROR_SERVICE_DOES_NOT_EXIST () { 1060 }
+sub ERROR_SERVICE_CANNOT_ACCEPT_CTRL () { 1061 }
+sub ERROR_SERVICE_NOT_ACTIVE () { 1062 }
+sub ERROR_FAILED_SERVICE_CONTROLLER_CONNECT () { 1063 }
+sub ERROR_EXCEPTION_IN_SERVICE () { 1064 }
+sub ERROR_DATABASE_DOES_NOT_EXIST () { 1065 }
+sub ERROR_SERVICE_SPECIFIC_ERROR () { 1066 }
+sub ERROR_PROCESS_ABORTED () { 1067 }
+sub ERROR_SERVICE_DEPENDENCY_FAIL () { 1068 }
+sub ERROR_SERVICE_LOGON_FAILED () { 1069 }
+sub ERROR_SERVICE_START_HANG () { 1070 }
+sub ERROR_INVALID_SERVICE_LOCK () { 1071 }
+sub ERROR_SERVICE_MARKED_FOR_DELETE () { 1072 }
+sub ERROR_SERVICE_EXISTS () { 1073 }
+sub ERROR_ALREADY_RUNNING_LKG () { 1074 }
+sub ERROR_SERVICE_DEPENDENCY_DELETED () { 1075 }
+sub ERROR_BOOT_ALREADY_ACCEPTED () { 1076 }
+sub ERROR_SERVICE_NEVER_STARTED () { 1077 }
+sub ERROR_DUPLICATE_SERVICE_NAME () { 1078 }
+sub ERROR_DIFFERENT_SERVICE_ACCOUNT () { 1079 }
+sub ERROR_CANNOT_DETECT_DRIVER_FAILURE () { 1080 }
+sub ERROR_CANNOT_DETECT_PROCESS_ABORT () { 1081 }
+sub ERROR_NO_RECOVERY_PROGRAM () { 1082 }
+sub ERROR_SERVICE_NOT_IN_EXE () { 1083 }
+sub ERROR_NOT_SAFEBOOT_SERVICE () { 1084 }
+sub ERROR_END_OF_MEDIA () { 1100 }
+sub ERROR_FILEMARK_DETECTED () { 1101 }
+sub ERROR_BEGINNING_OF_MEDIA () { 1102 }
+sub ERROR_SETMARK_DETECTED () { 1103 }
+sub ERROR_NO_DATA_DETECTED () { 1104 }
+sub ERROR_PARTITION_FAILURE () { 1105 }
+sub ERROR_INVALID_BLOCK_LENGTH () { 1106 }
+sub ERROR_DEVICE_NOT_PARTITIONED () { 1107 }
+sub ERROR_UNABLE_TO_LOCK_MEDIA () { 1108 }
+sub ERROR_UNABLE_TO_UNLOAD_MEDIA () { 1109 }
+sub ERROR_MEDIA_CHANGED () { 1110 }
+sub ERROR_BUS_RESET () { 1111 }
+sub ERROR_NO_MEDIA_IN_DRIVE () { 1112 }
+sub ERROR_NO_UNICODE_TRANSLATION () { 1113 }
+sub ERROR_DLL_INIT_FAILED () { 1114 }
+sub ERROR_SHUTDOWN_IN_PROGRESS () { 1115 }
+sub ERROR_NO_SHUTDOWN_IN_PROGRESS () { 1116 }
+sub ERROR_IO_DEVICE () { 1117 }
+sub ERROR_SERIAL_NO_DEVICE () { 1118 }
+sub ERROR_IRQ_BUSY () { 1119 }
+sub ERROR_MORE_WRITES () { 1120 }
+sub ERROR_COUNTER_TIMEOUT () { 1121 }
+sub ERROR_FLOPPY_ID_MARK_NOT_FOUND () { 1122 }
+sub ERROR_FLOPPY_WRONG_CYLINDER () { 1123 }
+sub ERROR_FLOPPY_UNKNOWN_ERROR () { 1124 }
+sub ERROR_FLOPPY_BAD_REGISTERS () { 1125 }
+sub ERROR_DISK_RECALIBRATE_FAILED () { 1126 }
+sub ERROR_DISK_OPERATION_FAILED () { 1127 }
+sub ERROR_DISK_RESET_FAILED () { 1128 }
+sub ERROR_EOM_OVERFLOW () { 1129 }
+sub ERROR_NOT_ENOUGH_SERVER_MEMORY () { 1130 }
+sub ERROR_POSSIBLE_DEADLOCK () { 1131 }
+sub ERROR_MAPPED_ALIGNMENT () { 1132 }
+sub ERROR_SET_POWER_STATE_VETOED () { 1140 }
+sub ERROR_SET_POWER_STATE_FAILED () { 1141 }
+sub ERROR_TOO_MANY_LINKS () { 1142 }
+sub ERROR_OLD_WIN_VERSION () { 1150 }
+sub ERROR_APP_WRONG_OS () { 1151 }
+sub ERROR_SINGLE_INSTANCE_APP () { 1152 }
+sub ERROR_RMODE_APP () { 1153 }
+sub ERROR_INVALID_DLL () { 1154 }
+sub ERROR_NO_ASSOCIATION () { 1155 }
+sub ERROR_DDE_FAIL () { 1156 }
+sub ERROR_DLL_NOT_FOUND () { 1157 }
+sub ERROR_NO_MORE_USER_HANDLES () { 1158 }
+sub ERROR_MESSAGE_SYNC_ONLY () { 1159 }
+sub ERROR_SOURCE_ELEMENT_EMPTY () { 1160 }
+sub ERROR_DESTINATION_ELEMENT_FULL () { 1161 }
+sub ERROR_ILLEGAL_ELEMENT_ADDRESS () { 1162 }
+sub ERROR_MAGAZINE_NOT_PRESENT () { 1163 }
+sub ERROR_DEVICE_REINITIALIZATION_NEEDED () { 1164 }
+sub ERROR_DEVICE_REQUIRES_CLEANING () { 1165 }
+sub ERROR_DEVICE_DOOR_OPEN () { 1166 }
+sub ERROR_DEVICE_NOT_CONNECTED () { 1167 }
+sub ERROR_NOT_FOUND () { 1168 }
+sub ERROR_NO_MATCH () { 1169 }
+sub ERROR_SET_NOT_FOUND () { 1170 }
+sub ERROR_POINT_NOT_FOUND () { 1171 }
+sub ERROR_NO_TRACKING_SERVICE () { 1172 }
+sub ERROR_NO_VOLUME_ID () { 1173 }
+sub ERROR_UNABLE_TO_REMOVE_REPLACED () { 1175 }
+sub ERROR_UNABLE_TO_MOVE_REPLACEMENT () { 1176 }
+sub ERROR_UNABLE_TO_MOVE_REPLACEMENT_2 () { 1177 }
+sub ERROR_JOURNAL_DELETE_IN_PROGRESS () { 1178 }
+sub ERROR_JOURNAL_NOT_ACTIVE () { 1179 }
+sub ERROR_POTENTIAL_FILE_FOUND () { 1180 }
+sub ERROR_JOURNAL_ENTRY_DELETED () { 1181 }
+sub ERROR_BAD_DEVICE () { 1200 }
+sub ERROR_CONNECTION_UNAVAIL () { 1201 }
+sub ERROR_DEVICE_ALREADY_REMEMBERED () { 1202 }
+sub ERROR_NO_NET_OR_BAD_PATH () { 1203 }
+sub ERROR_BAD_PROVIDER () { 1204 }
+sub ERROR_CANNOT_OPEN_PROFILE () { 1205 }
+sub ERROR_BAD_PROFILE () { 1206 }
+sub ERROR_NOT_CONTAINER () { 1207 }
+sub ERROR_EXTENDED_ERROR () { 1208 }
+sub ERROR_INVALID_GROUPNAME () { 1209 }
+sub ERROR_INVALID_COMPUTERNAME () { 1210 }
+sub ERROR_INVALID_EVENTNAME () { 1211 }
+sub ERROR_INVALID_DOMAINNAME () { 1212 }
+sub ERROR_INVALID_SERVICENAME () { 1213 }
+sub ERROR_INVALID_NETNAME () { 1214 }
+sub ERROR_INVALID_SHARENAME () { 1215 }
+sub ERROR_INVALID_PASSWORDNAME () { 1216 }
+sub ERROR_INVALID_MESSAGENAME () { 1217 }
+sub ERROR_INVALID_MESSAGEDEST () { 1218 }
+sub ERROR_SESSION_CREDENTIAL_CONFLICT () { 1219 }
+sub ERROR_REMOTE_SESSION_LIMIT_EXCEEDED () { 1220 }
+sub ERROR_DUP_DOMAINNAME () { 1221 }
+sub ERROR_NO_NETWORK () { 1222 }
+sub ERROR_CANCELLED () { 1223 }
+sub ERROR_USER_MAPPED_FILE () { 1224 }
+sub ERROR_CONNECTION_REFUSED () { 1225 }
+sub ERROR_GRACEFUL_DISCONNECT () { 1226 }
+sub ERROR_ADDRESS_ALREADY_ASSOCIATED () { 1227 }
+sub ERROR_ADDRESS_NOT_ASSOCIATED () { 1228 }
+sub ERROR_CONNECTION_INVALID () { 1229 }
+sub ERROR_CONNECTION_ACTIVE () { 1230 }
+sub ERROR_NETWORK_UNREACHABLE () { 1231 }
+sub ERROR_HOST_UNREACHABLE () { 1232 }
+sub ERROR_PROTOCOL_UNREACHABLE () { 1233 }
+sub ERROR_PORT_UNREACHABLE () { 1234 }
+sub ERROR_REQUEST_ABORTED () { 1235 }
+sub ERROR_CONNECTION_ABORTED () { 1236 }
+sub ERROR_RETRY () { 1237 }
+sub ERROR_CONNECTION_COUNT_LIMIT () { 1238 }
+sub ERROR_LOGIN_TIME_RESTRICTION () { 1239 }
+sub ERROR_LOGIN_WKSTA_RESTRICTION () { 1240 }
+sub ERROR_INCORRECT_ADDRESS () { 1241 }
+sub ERROR_ALREADY_REGISTERED () { 1242 }
+sub ERROR_SERVICE_NOT_FOUND () { 1243 }
+sub ERROR_NOT_AUTHENTICATED () { 1244 }
+sub ERROR_NOT_LOGGED_ON () { 1245 }
+sub ERROR_CONTINUE () { 1246 }
+sub ERROR_ALREADY_INITIALIZED () { 1247 }
+sub ERROR_NO_MORE_DEVICES () { 1248 }
+sub ERROR_NO_SUCH_SITE () { 1249 }
+sub ERROR_DOMAIN_CONTROLLER_EXISTS () { 1250 }
+sub ERROR_ONLY_IF_CONNECTED () { 1251 }
+sub ERROR_OVERRIDE_NOCHANGES () { 1252 }
+sub ERROR_BAD_USER_PROFILE () { 1253 }
+sub ERROR_NOT_SUPPORTED_ON_SBS () { 1254 }
+sub ERROR_SERVER_SHUTDOWN_IN_PROGRESS () { 1255 }
+sub ERROR_HOST_DOWN () { 1256 }
+sub ERROR_NON_ACCOUNT_SID () { 1257 }
+sub ERROR_NON_DOMAIN_SID () { 1258 }
+sub ERROR_APPHELP_BLOCK () { 1259 }
+sub ERROR_ACCESS_DISABLED_BY_POLICY () { 1260 }
+sub ERROR_REG_NAT_CONSUMPTION () { 1261 }
+sub ERROR_CSCSHARE_OFFLINE () { 1262 }
+sub ERROR_PKINIT_FAILURE () { 1263 }
+sub ERROR_SMARTCARD_SUBSYSTEM_FAILURE () { 1264 }
+sub ERROR_DOWNGRADE_DETECTED () { 1265 }
+sub ERROR_MACHINE_LOCKED () { 1271 }
+sub ERROR_CALLBACK_SUPPLIED_INVALID_DATA () { 1273 }
+sub ERROR_SYNC_FOREGROUND_REFRESH_REQUIRED () { 1274 }
+sub ERROR_DRIVER_BLOCKED () { 1275 }
+sub ERROR_INVALID_IMPORT_OF_NON_DLL () { 1276 }
+sub ERROR_ACCESS_DISABLED_WEBBLADE () { 1277 }
+sub ERROR_ACCESS_DISABLED_WEBBLADE_TAMPER () { 1278 }
+sub ERROR_RECOVERY_FAILURE () { 1279 }
+sub ERROR_ALREADY_FIBER () { 1280 }
+sub EN_ERRSPACE () { 1280 }
+sub ERROR_ALREADY_THREAD () { 1281 }
+sub EN_MAXTEXT () { 1281 }
+sub ERROR_STACK_BUFFER_OVERRUN () { 1282 }
+sub ERROR_PARAMETER_QUOTA_EXCEEDED () { 1283 }
+sub ERROR_DEBUGGER_INACTIVE () { 1284 }
+sub ERROR_NOT_ALL_ASSIGNED () { 1300 }
+sub ERROR_SOME_NOT_MAPPED () { 1301 }
+sub ERROR_NO_QUOTAS_FOR_ACCOUNT () { 1302 }
+sub ERROR_LOCAL_USER_SESSION_KEY () { 1303 }
+sub ERROR_NULL_LM_PASSWORD () { 1304 }
+sub ERROR_UNKNOWN_REVISION () { 1305 }
+sub ERROR_REVISION_MISMATCH () { 1306 }
+sub ERROR_INVALID_OWNER () { 1307 }
+sub ERROR_INVALID_PRIMARY_GROUP () { 1308 }
+sub ERROR_NO_IMPERSONATION_TOKEN () { 1309 }
+sub ERROR_CANT_DISABLE_MANDATORY () { 1310 }
+sub ERROR_NO_LOGON_SERVERS () { 1311 }
+sub ERROR_NO_SUCH_LOGON_SESSION () { 1312 }
+sub ERROR_NO_SUCH_PRIVILEGE () { 1313 }
+sub ERROR_PRIVILEGE_NOT_HELD () { 1314 }
+sub ERROR_INVALID_ACCOUNT_NAME () { 1315 }
+sub ERROR_USER_EXISTS () { 1316 }
+sub ERROR_NO_SUCH_USER () { 1317 }
+sub ERROR_GROUP_EXISTS () { 1318 }
+sub ERROR_NO_SUCH_GROUP () { 1319 }
+sub ERROR_MEMBER_IN_GROUP () { 1320 }
+sub ERROR_MEMBER_NOT_IN_GROUP () { 1321 }
+sub ERROR_LAST_ADMIN () { 1322 }
+sub ERROR_WRONG_PASSWORD () { 1323 }
+sub ERROR_ILL_FORMED_PASSWORD () { 1324 }
+sub ERROR_PASSWORD_RESTRICTION () { 1325 }
+sub ERROR_LOGON_FAILURE () { 1326 }
+sub ERROR_ACCOUNT_RESTRICTION () { 1327 }
+sub ERROR_INVALID_LOGON_HOURS () { 1328 }
+sub ERROR_INVALID_WORKSTATION () { 1329 }
+sub ERROR_PASSWORD_EXPIRED () { 1330 }
+sub ERROR_ACCOUNT_DISABLED () { 1331 }
+sub ERROR_NONE_MAPPED () { 1332 }
+sub ERROR_TOO_MANY_LUIDS_REQUESTED () { 1333 }
+sub ERROR_LUIDS_EXHAUSTED () { 1334 }
+sub ERROR_INVALID_SUB_AUTHORITY () { 1335 }
+sub ERROR_INVALID_ACL () { 1336 }
+sub ERROR_INVALID_SID () { 1337 }
+sub ERROR_INVALID_SECURITY_DESCR () { 1338 }
+sub ERROR_BAD_INHERITANCE_ACL () { 1340 }
+sub ERROR_SERVER_DISABLED () { 1341 }
+sub ERROR_SERVER_NOT_DISABLED () { 1342 }
+sub ERROR_INVALID_ID_AUTHORITY () { 1343 }
+sub ERROR_ALLOTTED_SPACE_EXCEEDED () { 1344 }
+sub ERROR_INVALID_GROUP_ATTRIBUTES () { 1345 }
+sub ERROR_BAD_IMPERSONATION_LEVEL () { 1346 }
+sub ERROR_CANT_OPEN_ANONYMOUS () { 1347 }
+sub ERROR_BAD_VALIDATION_CLASS () { 1348 }
+sub ERROR_BAD_TOKEN_TYPE () { 1349 }
+sub ERROR_NO_SECURITY_ON_OBJECT () { 1350 }
+sub ERROR_CANT_ACCESS_DOMAIN_INFO () { 1351 }
+sub ERROR_INVALID_SERVER_STATE () { 1352 }
+sub ERROR_INVALID_DOMAIN_STATE () { 1353 }
+sub ERROR_INVALID_DOMAIN_ROLE () { 1354 }
+sub ERROR_NO_SUCH_DOMAIN () { 1355 }
+sub ERROR_DOMAIN_EXISTS () { 1356 }
+sub ERROR_DOMAIN_LIMIT_EXCEEDED () { 1357 }
+sub ERROR_INTERNAL_DB_CORRUPTION () { 1358 }
+sub ERROR_INTERNAL_ERROR () { 1359 }
+sub ERROR_GENERIC_NOT_MAPPED () { 1360 }
+sub ERROR_BAD_DESCRIPTOR_FORMAT () { 1361 }
+sub ERROR_NOT_LOGON_PROCESS () { 1362 }
+sub ERROR_LOGON_SESSION_EXISTS () { 1363 }
+sub ERROR_NO_SUCH_PACKAGE () { 1364 }
+sub ERROR_BAD_LOGON_SESSION_STATE () { 1365 }
+sub ERROR_LOGON_SESSION_COLLISION () { 1366 }
+sub ERROR_INVALID_LOGON_TYPE () { 1367 }
+sub ERROR_CANNOT_IMPERSONATE () { 1368 }
+sub ERROR_RXACT_INVALID_STATE () { 1369 }
+sub ERROR_RXACT_COMMIT_FAILURE () { 1370 }
+sub ERROR_SPECIAL_ACCOUNT () { 1371 }
+sub ERROR_SPECIAL_GROUP () { 1372 }
+sub ERROR_SPECIAL_USER () { 1373 }
+sub ERROR_MEMBERS_PRIMARY_GROUP () { 1374 }
+sub ERROR_TOKEN_ALREADY_IN_USE () { 1375 }
+sub ERROR_NO_SUCH_ALIAS () { 1376 }
+sub ERROR_MEMBER_NOT_IN_ALIAS () { 1377 }
+sub ERROR_MEMBER_IN_ALIAS () { 1378 }
+sub ERROR_ALIAS_EXISTS () { 1379 }
+sub ERROR_LOGON_NOT_GRANTED () { 1380 }
+sub ERROR_TOO_MANY_SECRETS () { 1381 }
+sub ERROR_SECRET_TOO_LONG () { 1382 }
+sub ERROR_INTERNAL_DB_ERROR () { 1383 }
+sub ERROR_TOO_MANY_CONTEXT_IDS () { 1384 }
+sub ERROR_LOGON_TYPE_NOT_GRANTED () { 1385 }
+sub ERROR_NT_CROSS_ENCRYPTION_REQUIRED () { 1386 }
+sub ERROR_NO_SUCH_MEMBER () { 1387 }
+sub ERROR_INVALID_MEMBER () { 1388 }
+sub ERROR_TOO_MANY_SIDS () { 1389 }
+sub ERROR_LM_CROSS_ENCRYPTION_REQUIRED () { 1390 }
+sub ERROR_NO_INHERITANCE () { 1391 }
+sub ERROR_FILE_CORRUPT () { 1392 }
+sub ERROR_DISK_CORRUPT () { 1393 }
+sub ERROR_NO_USER_SESSION_KEY () { 1394 }
+sub ERROR_LICENSE_QUOTA_EXCEEDED () { 1395 }
+sub ERROR_WRONG_TARGET_NAME () { 1396 }
+sub ERROR_MUTUAL_AUTH_FAILED () { 1397 }
+sub ERROR_TIME_SKEW () { 1398 }
+sub ERROR_CURRENT_DOMAIN_NOT_ALLOWED () { 1399 }
+sub ERROR_INVALID_WINDOW_HANDLE () { 1400 }
+sub ERROR_INVALID_MENU_HANDLE () { 1401 }
+sub ERROR_INVALID_CURSOR_HANDLE () { 1402 }
+sub ERROR_INVALID_ACCEL_HANDLE () { 1403 }
+sub ERROR_INVALID_HOOK_HANDLE () { 1404 }
+sub ERROR_INVALID_DWP_HANDLE () { 1405 }
+sub ERROR_TLW_WITH_WSCHILD () { 1406 }
+sub ERROR_CANNOT_FIND_WND_CLASS () { 1407 }
+sub ERROR_WINDOW_OF_OTHER_THREAD () { 1408 }
+sub ERROR_HOTKEY_ALREADY_REGISTERED () { 1409 }
+sub ERROR_CLASS_ALREADY_EXISTS () { 1410 }
+sub ERROR_CLASS_DOES_NOT_EXIST () { 1411 }
+sub ERROR_CLASS_HAS_WINDOWS () { 1412 }
+sub ERROR_INVALID_INDEX () { 1413 }
+sub ERROR_INVALID_ICON_HANDLE () { 1414 }
+sub ERROR_PRIVATE_DIALOG_INDEX () { 1415 }
+sub ERROR_LISTBOX_ID_NOT_FOUND () { 1416 }
+sub ERROR_NO_WILDCARD_CHARACTERS () { 1417 }
+sub ERROR_CLIPBOARD_NOT_OPEN () { 1418 }
+sub ERROR_HOTKEY_NOT_REGISTERED () { 1419 }
+sub ERROR_WINDOW_NOT_DIALOG () { 1420 }
+sub ERROR_CONTROL_ID_NOT_FOUND () { 1421 }
+sub ERROR_INVALID_COMBOBOX_MESSAGE () { 1422 }
+sub ERROR_WINDOW_NOT_COMBOBOX () { 1423 }
+sub ERROR_INVALID_EDIT_HEIGHT () { 1424 }
+sub ERROR_DC_NOT_FOUND () { 1425 }
+sub ERROR_INVALID_HOOK_FILTER () { 1426 }
+sub ERROR_INVALID_FILTER_PROC () { 1427 }
+sub ERROR_HOOK_NEEDS_HMOD () { 1428 }
+sub ERROR_GLOBAL_ONLY_HOOK () { 1429 }
+sub ERROR_JOURNAL_HOOK_SET () { 1430 }
+sub ERROR_HOOK_NOT_INSTALLED () { 1431 }
+sub ERROR_INVALID_LB_MESSAGE () { 1432 }
+sub ERROR_SETCOUNT_ON_BAD_LB () { 1433 }
+sub ERROR_LB_WITHOUT_TABSTOPS () { 1434 }
+sub ERROR_DESTROY_OBJECT_OF_OTHER_THREAD () { 1435 }
+sub ERROR_CHILD_WINDOW_MENU () { 1436 }
+sub ERROR_NO_SYSTEM_MENU () { 1437 }
+sub ERROR_INVALID_MSGBOX_STYLE () { 1438 }
+sub ERROR_INVALID_SPI_VALUE () { 1439 }
+sub ERROR_SCREEN_ALREADY_LOCKED () { 1440 }
+sub ERROR_HWNDS_HAVE_DIFF_PARENT () { 1441 }
+sub ERROR_NOT_CHILD_WINDOW () { 1442 }
+sub ERROR_INVALID_GW_COMMAND () { 1443 }
+sub ERROR_INVALID_THREAD_ID () { 1444 }
+sub ERROR_NON_MDICHILD_WINDOW () { 1445 }
+sub ERROR_POPUP_ALREADY_ACTIVE () { 1446 }
+sub ERROR_NO_SCROLLBARS () { 1447 }
+sub ERROR_INVALID_SCROLLBAR_RANGE () { 1448 }
+sub ERROR_INVALID_SHOWWIN_COMMAND () { 1449 }
+sub ERROR_NO_SYSTEM_RESOURCES () { 1450 }
+sub ERROR_NONPAGED_SYSTEM_RESOURCES () { 1451 }
+sub ERROR_PAGED_SYSTEM_RESOURCES () { 1452 }
+sub ERROR_WORKING_SET_QUOTA () { 1453 }
+sub ERROR_PAGEFILE_QUOTA () { 1454 }
+sub ERROR_COMMITMENT_LIMIT () { 1455 }
+sub ERROR_MENU_ITEM_NOT_FOUND () { 1456 }
+sub ERROR_INVALID_KEYBOARD_HANDLE () { 1457 }
+sub ERROR_HOOK_TYPE_NOT_ALLOWED () { 1458 }
+sub ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION () { 1459 }
+sub ERROR_TIMEOUT () { 1460 }
+sub ERROR_INVALID_MONITOR_HANDLE () { 1461 }
+sub ERROR_EVENTLOG_FILE_CORRUPT () { 1500 }
+sub ERROR_EVENTLOG_CANT_START () { 1501 }
+sub ERROR_LOG_FILE_FULL () { 1502 }
+sub ERROR_EVENTLOG_FILE_CHANGED () { 1503 }
+sub EN_HSCROLL () { 1537 }
+sub EN_VSCROLL () { 1538 }
+sub ERROR_INSTALL_SERVICE_FAILURE () { 1601 }
+sub ERROR_INSTALL_USEREXIT () { 1602 }
+sub ERROR_INSTALL_FAILURE () { 1603 }
+sub ERROR_INSTALL_SUSPEND () { 1604 }
+sub ERROR_UNKNOWN_PRODUCT () { 1605 }
+sub ERROR_UNKNOWN_FEATURE () { 1606 }
+sub ERROR_UNKNOWN_COMPONENT () { 1607 }
+sub ERROR_UNKNOWN_PROPERTY () { 1608 }
+sub ERROR_INVALID_HANDLE_STATE () { 1609 }
+sub ERROR_BAD_CONFIGURATION () { 1610 }
+sub ERROR_INDEX_ABSENT () { 1611 }
+sub ERROR_INSTALL_SOURCE_ABSENT () { 1612 }
+sub ERROR_INSTALL_PACKAGE_VERSION () { 1613 }
+sub ERROR_PRODUCT_UNINSTALLED () { 1614 }
+sub ERROR_BAD_QUERY_SYNTAX () { 1615 }
+sub ERROR_INVALID_FIELD () { 1616 }
+sub ERROR_DEVICE_REMOVED () { 1617 }
+sub ERROR_INSTALL_ALREADY_RUNNING () { 1618 }
+sub ERROR_INSTALL_PACKAGE_OPEN_FAILED () { 1619 }
+sub ERROR_INSTALL_PACKAGE_INVALID () { 1620 }
+sub ERROR_INSTALL_UI_FAILURE () { 1621 }
+sub ERROR_INSTALL_LOG_FAILURE () { 1622 }
+sub ERROR_INSTALL_LANGUAGE_UNSUPPORTED () { 1623 }
+sub ERROR_INSTALL_TRANSFORM_FAILURE () { 1624 }
+sub ERROR_INSTALL_PACKAGE_REJECTED () { 1625 }
+sub ERROR_FUNCTION_NOT_CALLED () { 1626 }
+sub ERROR_FUNCTION_FAILED () { 1627 }
+sub ERROR_INVALID_TABLE () { 1628 }
+sub ERROR_DATATYPE_MISMATCH () { 1629 }
+sub ERROR_UNSUPPORTED_TYPE () { 1630 }
+sub ERROR_CREATE_FAILED () { 1631 }
+sub ERROR_INSTALL_TEMP_UNWRITABLE () { 1632 }
+sub ERROR_INSTALL_PLATFORM_UNSUPPORTED () { 1633 }
+sub ERROR_INSTALL_NOTUSED () { 1634 }
+sub ERROR_PATCH_PACKAGE_OPEN_FAILED () { 1635 }
+sub ERROR_PATCH_PACKAGE_INVALID () { 1636 }
+sub ERROR_PATCH_PACKAGE_UNSUPPORTED () { 1637 }
+sub ERROR_PRODUCT_VERSION () { 1638 }
+sub ERROR_INVALID_COMMAND_LINE () { 1639 }
+sub ERROR_INSTALL_REMOTE_DISALLOWED () { 1640 }
+sub ERROR_SUCCESS_REBOOT_INITIATED () { 1641 }
+sub ERROR_PATCH_TARGET_NOT_FOUND () { 1642 }
+sub ERROR_PATCH_PACKAGE_REJECTED () { 1643 }
+sub ERROR_INSTALL_TRANSFORM_REJECTED () { 1644 }
+sub ERROR_INSTALL_REMOTE_PROHIBITED () { 1645 }
+sub EPT_S_INVALID_ENTRY () { 1751 }
+sub EPT_S_CANT_PERFORM_OP () { 1752 }
+sub EPT_S_NOT_REGISTERED () { 1753 }
+sub ERROR_INVALID_USER_BUFFER () { 1784 }
+sub ERROR_UNRECOGNIZED_MEDIA () { 1785 }
+sub ERROR_NO_TRUST_LSA_SECRET () { 1786 }
+sub ERROR_NO_TRUST_SAM_ACCOUNT () { 1787 }
+sub ERROR_TRUSTED_DOMAIN_FAILURE () { 1788 }
+sub ERROR_TRUSTED_RELATIONSHIP_FAILURE () { 1789 }
+sub ERROR_TRUST_FAILURE () { 1790 }
+sub ERROR_NETLOGON_NOT_STARTED () { 1792 }
+sub ERROR_ACCOUNT_EXPIRED () { 1793 }
+sub ERROR_REDIRECTOR_HAS_OPEN_HANDLES () { 1794 }
+sub ERROR_PRINTER_DRIVER_ALREADY_INSTALLED () { 1795 }
+sub ERROR_UNKNOWN_PORT () { 1796 }
+sub ERROR_UNKNOWN_PRINTER_DRIVER () { 1797 }
+sub ERROR_UNKNOWN_PRINTPROCESSOR () { 1798 }
+sub ERROR_INVALID_SEPARATOR_FILE () { 1799 }
+sub ERROR_INVALID_PRIORITY () { 1800 }
+sub ERROR_INVALID_PRINTER_NAME () { 1801 }
+sub ERROR_PRINTER_ALREADY_EXISTS () { 1802 }
+sub ERROR_INVALID_PRINTER_COMMAND () { 1803 }
+sub ERROR_INVALID_DATATYPE () { 1804 }
+sub ERROR_INVALID_ENVIRONMENT () { 1805 }
+sub ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT () { 1807 }
+sub ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT () { 1808 }
+sub ERROR_NOLOGON_SERVER_TRUST_ACCOUNT () { 1809 }
+sub ERROR_DOMAIN_TRUST_INCONSISTENT () { 1810 }
+sub ERROR_SERVER_HAS_OPEN_HANDLES () { 1811 }
+sub ERROR_RESOURCE_DATA_NOT_FOUND () { 1812 }
+sub ERROR_RESOURCE_TYPE_NOT_FOUND () { 1813 }
+sub ERROR_RESOURCE_NAME_NOT_FOUND () { 1814 }
+sub ERROR_RESOURCE_LANG_NOT_FOUND () { 1815 }
+sub ERROR_NOT_ENOUGH_QUOTA () { 1816 }
+sub EPT_S_CANT_CREATE () { 1899 }
+sub ERROR_INVALID_TIME () { 1901 }
+sub ERROR_INVALID_FORM_NAME () { 1902 }
+sub ERROR_INVALID_FORM_SIZE () { 1903 }
+sub ERROR_ALREADY_WAITING () { 1904 }
+sub ERROR_PRINTER_DELETED () { 1905 }
+sub ERROR_INVALID_PRINTER_STATE () { 1906 }
+sub ERROR_PASSWORD_MUST_CHANGE () { 1907 }
+sub ERROR_DOMAIN_CONTROLLER_NOT_FOUND () { 1908 }
+sub ERROR_ACCOUNT_LOCKED_OUT () { 1909 }
+sub ERROR_NO_SITENAME () { 1919 }
+sub ERROR_CANT_ACCESS_FILE () { 1920 }
+sub ERROR_CANT_RESOLVE_FILENAME () { 1921 }
+sub ERROR_KM_DRIVER_BLOCKED () { 1930 }
+sub ERROR_CONTEXT_EXPIRED () { 1931 }
+sub ERROR_PER_USER_TRUST_QUOTA_EXCEEDED () { 1932 }
+sub ERROR_ALL_USER_TRUST_QUOTA_EXCEEDED () { 1933 }
+sub ERROR_USER_DELETE_TRUST_QUOTA_EXCEEDED () { 1934 }
+sub ERROR_INVALID_PIXEL_FORMAT () { 2000 }
+sub ERROR_BAD_DRIVER () { 2001 }
+sub ERROR_INVALID_WINDOW_STYLE () { 2002 }
+sub ERROR_METAFILE_NOT_SUPPORTED () { 2003 }
+sub ERROR_TRANSFORM_NOT_SUPPORTED () { 2004 }
+sub ERROR_CLIPPING_NOT_SUPPORTED () { 2005 }
+sub ERROR_INVALID_CMM () { 2010 }
+sub ERROR_INVALID_PROFILE () { 2011 }
+sub ERROR_TAG_NOT_FOUND () { 2012 }
+sub ERROR_TAG_NOT_PRESENT () { 2013 }
+sub ERROR_DUPLICATE_TAG () { 2014 }
+sub ERROR_PROFILE_NOT_ASSOCIATED_WITH_DEVICE () { 2015 }
+sub ERROR_PROFILE_NOT_FOUND () { 2016 }
+sub ERROR_INVALID_COLORSPACE () { 2017 }
+sub ERROR_ICM_NOT_ENABLED () { 2018 }
+sub ERROR_DELETING_ICM_XFORM () { 2019 }
+sub ERROR_INVALID_TRANSFORM () { 2020 }
+sub ERROR_COLORSPACE_MISMATCH () { 2021 }
+sub ERROR_INVALID_COLORINDEX () { 2022 }
+sub ETO_NUMERICSLATIN () { 2048 }
+sub EV_EVENT1 () { 2048 }
+sub ES_READONLY () { 2048 }
+sub ERROR_CONNECTED_OTHER_PASSWORD () { 2108 }
+sub ERROR_CONNECTED_OTHER_PASSWORD_DEFAULT () { 2109 }
+sub ERROR_BAD_USERNAME () { 2202 }
+sub ERROR_NOT_CONNECTED () { 2250 }
+sub ERROR_OPEN_FILES () { 2401 }
+sub ERROR_ACTIVE_CONNECTIONS () { 2402 }
+sub ERROR_DEVICE_IN_USE () { 2404 }
+sub ERROR_UNKNOWN_PRINT_MONITOR () { 3000 }
+sub ERROR_PRINTER_DRIVER_IN_USE () { 3001 }
+sub ERROR_SPOOL_FILE_NOT_FOUND () { 3002 }
+sub ERROR_SPL_NO_STARTDOC () { 3003 }
+sub ERROR_SPL_NO_ADDJOB () { 3004 }
+sub ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED () { 3005 }
+sub ERROR_PRINT_MONITOR_ALREADY_INSTALLED () { 3006 }
+sub ERROR_INVALID_PRINT_MONITOR () { 3007 }
+sub ERROR_PRINT_MONITOR_IN_USE () { 3008 }
+sub ERROR_PRINTER_HAS_JOBS_QUEUED () { 3009 }
+sub ERROR_SUCCESS_REBOOT_REQUIRED () { 3010 }
+sub ERROR_SUCCESS_RESTART_REQUIRED () { 3011 }
+sub ERROR_PRINTER_NOT_FOUND () { 3012 }
+sub ERROR_PRINTER_DRIVER_WARNED () { 3013 }
+sub ERROR_PRINTER_DRIVER_BLOCKED () { 3014 }
+sub ERROR_WINS_INTERNAL () { 4000 }
+sub ERROR_CAN_NOT_DEL_LOCAL_WINS () { 4001 }
+sub ERROR_STATIC_INIT () { 4002 }
+sub ERROR_INC_BACKUP () { 4003 }
+sub ERROR_FULL_BACKUP () { 4004 }
+sub ERROR_REC_NON_EXISTENT () { 4005 }
+sub ERROR_RPL_NOT_ALLOWED () { 4006 }
+sub ETO_IGNORELANGUAGE () { 4096 }
+sub EV_EVENT2 () { 4096 }
+sub ES_WANTRETURN () { 4096 }
+sub END_PATH () { 4098 }
+sub EXT_DEVICE_CAPS () { 4099 }
+sub ERROR_DHCP_ADDRESS_CONFLICT () { 4100 }
+sub ENCAPSULATED_POSTSCRIPT () { 4116 }
+sub ERROR_WMI_GUID_NOT_FOUND () { 4200 }
+sub ERROR_WMI_INSTANCE_NOT_FOUND () { 4201 }
+sub ERROR_WMI_ITEMID_NOT_FOUND () { 4202 }
+sub ERROR_WMI_TRY_AGAIN () { 4203 }
+sub ERROR_WMI_DP_NOT_FOUND () { 4204 }
+sub ERROR_WMI_UNRESOLVED_INSTANCE_REF () { 4205 }
+sub ERROR_WMI_ALREADY_ENABLED () { 4206 }
+sub ERROR_WMI_GUID_DISCONNECTED () { 4207 }
+sub ERROR_WMI_SERVER_UNAVAILABLE () { 4208 }
+sub ERROR_WMI_DP_FAILED () { 4209 }
+sub ERROR_WMI_INVALID_MOF () { 4210 }
+sub ERROR_WMI_INVALID_REGINFO () { 4211 }
+sub ERROR_WMI_ALREADY_DISABLED () { 4212 }
+sub ERROR_WMI_READ_ONLY () { 4213 }
+sub ERROR_WMI_SET_FAILURE () { 4214 }
+sub ERROR_INVALID_MEDIA () { 4300 }
+sub ERROR_INVALID_LIBRARY () { 4301 }
+sub ERROR_INVALID_MEDIA_POOL () { 4302 }
+sub ERROR_DRIVE_MEDIA_MISMATCH () { 4303 }
+sub ERROR_MEDIA_OFFLINE () { 4304 }
+sub ERROR_LIBRARY_OFFLINE () { 4305 }
+sub ERROR_EMPTY () { 4306 }
+sub ERROR_NOT_EMPTY () { 4307 }
+sub ERROR_MEDIA_UNAVAILABLE () { 4308 }
+sub ERROR_RESOURCE_DISABLED () { 4309 }
+sub ERROR_INVALID_CLEANER () { 4310 }
+sub ERROR_UNABLE_TO_CLEAN () { 4311 }
+sub ERROR_OBJECT_NOT_FOUND () { 4312 }
+sub ERROR_DATABASE_FAILURE () { 4313 }
+sub ERROR_DATABASE_FULL () { 4314 }
+sub ERROR_MEDIA_INCOMPATIBLE () { 4315 }
+sub ERROR_RESOURCE_NOT_PRESENT () { 4316 }
+sub ERROR_INVALID_OPERATION () { 4317 }
+sub ERROR_MEDIA_NOT_AVAILABLE () { 4318 }
+sub ERROR_DEVICE_NOT_AVAILABLE () { 4319 }
+sub ERROR_REQUEST_REFUSED () { 4320 }
+sub ERROR_INVALID_DRIVE_OBJECT () { 4321 }
+sub ERROR_LIBRARY_FULL () { 4322 }
+sub ERROR_MEDIUM_NOT_ACCESSIBLE () { 4323 }
+sub ERROR_UNABLE_TO_LOAD_MEDIUM () { 4324 }
+sub ERROR_UNABLE_TO_INVENTORY_DRIVE () { 4325 }
+sub ERROR_UNABLE_TO_INVENTORY_SLOT () { 4326 }
+sub ERROR_UNABLE_TO_INVENTORY_TRANSPORT () { 4327 }
+sub ERROR_TRANSPORT_FULL () { 4328 }
+sub ERROR_CONTROLLING_IEPORT () { 4329 }
+sub ERROR_UNABLE_TO_EJECT_MOUNTED_MEDIA () { 4330 }
+sub ERROR_CLEANER_SLOT_SET () { 4331 }
+sub ERROR_CLEANER_SLOT_NOT_SET () { 4332 }
+sub ERROR_CLEANER_CARTRIDGE_SPENT () { 4333 }
+sub ERROR_UNEXPECTED_OMID () { 4334 }
+sub ERROR_CANT_DELETE_LAST_ITEM () { 4335 }
+sub ERROR_MESSAGE_EXCEEDS_MAX_SIZE () { 4336 }
+sub ERROR_VOLUME_CONTAINS_SYS_FILES () { 4337 }
+sub ERROR_INDIGENOUS_TYPE () { 4338 }
+sub ERROR_NO_SUPPORTING_DRIVES () { 4339 }
+sub ERROR_CLEANER_CARTRIDGE_INSTALLED () { 4340 }
+sub ERROR_FILE_OFFLINE () { 4350 }
+sub ERROR_REMOTE_STORAGE_NOT_ACTIVE () { 4351 }
+sub ERROR_REMOTE_STORAGE_MEDIA_ERROR () { 4352 }
+sub ERROR_NOT_A_REPARSE_POINT () { 4390 }
+sub ERROR_REPARSE_ATTRIBUTE_CONFLICT () { 4391 }
+sub ERROR_INVALID_REPARSE_DATA () { 4392 }
+sub ERROR_REPARSE_TAG_INVALID () { 4393 }
+sub ERROR_REPARSE_TAG_MISMATCH () { 4394 }
+sub ERROR_VOLUME_NOT_SIS_ENABLED () { 4500 }
+sub ERROR_DEPENDENT_RESOURCE_EXISTS () { 5001 }
+sub ERROR_DEPENDENCY_NOT_FOUND () { 5002 }
+sub ERROR_DEPENDENCY_ALREADY_EXISTS () { 5003 }
+sub ERROR_RESOURCE_NOT_ONLINE () { 5004 }
+sub ERROR_HOST_NODE_NOT_AVAILABLE () { 5005 }
+sub ERROR_RESOURCE_NOT_AVAILABLE () { 5006 }
+sub ERROR_RESOURCE_NOT_FOUND () { 5007 }
+sub ERROR_SHUTDOWN_CLUSTER () { 5008 }
+sub ERROR_CANT_EVICT_ACTIVE_NODE () { 5009 }
+sub ERROR_OBJECT_ALREADY_EXISTS () { 5010 }
+sub ERROR_OBJECT_IN_LIST () { 5011 }
+sub ERROR_GROUP_NOT_AVAILABLE () { 5012 }
+sub ERROR_GROUP_NOT_FOUND () { 5013 }
+sub ERROR_GROUP_NOT_ONLINE () { 5014 }
+sub ERROR_HOST_NODE_NOT_RESOURCE_OWNER () { 5015 }
+sub ERROR_HOST_NODE_NOT_GROUP_OWNER () { 5016 }
+sub ERROR_RESMON_CREATE_FAILED () { 5017 }
+sub ERROR_RESMON_ONLINE_FAILED () { 5018 }
+sub ERROR_RESOURCE_ONLINE () { 5019 }
+sub ERROR_QUORUM_RESOURCE () { 5020 }
+sub ERROR_NOT_QUORUM_CAPABLE () { 5021 }
+sub ERROR_CLUSTER_SHUTTING_DOWN () { 5022 }
+sub ERROR_INVALID_STATE () { 5023 }
+sub ERROR_RESOURCE_PROPERTIES_STORED () { 5024 }
+sub ERROR_NOT_QUORUM_CLASS () { 5025 }
+sub ERROR_CORE_RESOURCE () { 5026 }
+sub ERROR_QUORUM_RESOURCE_ONLINE_FAILED () { 5027 }
+sub ERROR_QUORUMLOG_OPEN_FAILED () { 5028 }
+sub ERROR_CLUSTERLOG_CORRUPT () { 5029 }
+sub ERROR_CLUSTERLOG_RECORD_EXCEEDS_MAXSIZE () { 5030 }
+sub ERROR_CLUSTERLOG_EXCEEDS_MAXSIZE () { 5031 }
+sub ERROR_CLUSTERLOG_CHKPOINT_NOT_FOUND () { 5032 }
+sub ERROR_CLUSTERLOG_NOT_ENOUGH_SPACE () { 5033 }
+sub ERROR_QUORUM_OWNER_ALIVE () { 5034 }
+sub ERROR_NETWORK_NOT_AVAILABLE () { 5035 }
+sub ERROR_NODE_NOT_AVAILABLE () { 5036 }
+sub ERROR_ALL_NODES_NOT_AVAILABLE () { 5037 }
+sub ERROR_RESOURCE_FAILED () { 5038 }
+sub ERROR_CLUSTER_INVALID_NODE () { 5039 }
+sub ERROR_CLUSTER_NODE_EXISTS () { 5040 }
+sub ERROR_CLUSTER_JOIN_IN_PROGRESS () { 5041 }
+sub ERROR_CLUSTER_NODE_NOT_FOUND () { 5042 }
+sub ERROR_CLUSTER_LOCAL_NODE_NOT_FOUND () { 5043 }
+sub ERROR_CLUSTER_NETWORK_EXISTS () { 5044 }
+sub ERROR_CLUSTER_NETWORK_NOT_FOUND () { 5045 }
+sub ERROR_CLUSTER_NETINTERFACE_EXISTS () { 5046 }
+sub ERROR_CLUSTER_NETINTERFACE_NOT_FOUND () { 5047 }
+sub ERROR_CLUSTER_INVALID_REQUEST () { 5048 }
+sub ERROR_CLUSTER_INVALID_NETWORK_PROVIDER () { 5049 }
+sub ERROR_CLUSTER_NODE_DOWN () { 5050 }
+sub ERROR_CLUSTER_NODE_UNREACHABLE () { 5051 }
+sub ERROR_CLUSTER_NODE_NOT_MEMBER () { 5052 }
+sub ERROR_CLUSTER_JOIN_NOT_IN_PROGRESS () { 5053 }
+sub ERROR_CLUSTER_INVALID_NETWORK () { 5054 }
+sub ERROR_CLUSTER_NODE_UP () { 5056 }
+sub ERROR_CLUSTER_IPADDR_IN_USE () { 5057 }
+sub ERROR_CLUSTER_NODE_NOT_PAUSED () { 5058 }
+sub ERROR_CLUSTER_NO_SECURITY_CONTEXT () { 5059 }
+sub ERROR_CLUSTER_NETWORK_NOT_INTERNAL () { 5060 }
+sub ERROR_CLUSTER_NODE_ALREADY_UP () { 5061 }
+sub ERROR_CLUSTER_NODE_ALREADY_DOWN () { 5062 }
+sub ERROR_CLUSTER_NETWORK_ALREADY_ONLINE () { 5063 }
+sub ERROR_CLUSTER_NETWORK_ALREADY_OFFLINE () { 5064 }
+sub ERROR_CLUSTER_NODE_ALREADY_MEMBER () { 5065 }
+sub ERROR_CLUSTER_LAST_INTERNAL_NETWORK () { 5066 }
+sub ERROR_CLUSTER_NETWORK_HAS_DEPENDENTS () { 5067 }
+sub ERROR_INVALID_OPERATION_ON_QUORUM () { 5068 }
+sub ERROR_DEPENDENCY_NOT_ALLOWED () { 5069 }
+sub ERROR_CLUSTER_NODE_PAUSED () { 5070 }
+sub ERROR_NODE_CANT_HOST_RESOURCE () { 5071 }
+sub ERROR_CLUSTER_NODE_NOT_READY () { 5072 }
+sub ERROR_CLUSTER_NODE_SHUTTING_DOWN () { 5073 }
+sub ERROR_CLUSTER_JOIN_ABORTED () { 5074 }
+sub ERROR_CLUSTER_INCOMPATIBLE_VERSIONS () { 5075 }
+sub ERROR_CLUSTER_MAXNUM_OF_RESOURCES_EXCEEDED () { 5076 }
+sub ERROR_CLUSTER_SYSTEM_CONFIG_CHANGED () { 5077 }
+sub ERROR_CLUSTER_RESOURCE_TYPE_NOT_FOUND () { 5078 }
+sub ERROR_CLUSTER_RESTYPE_NOT_SUPPORTED () { 5079 }
+sub ERROR_CLUSTER_RESNAME_NOT_FOUND () { 5080 }
+sub ERROR_CLUSTER_NO_RPC_PACKAGES_REGISTERED () { 5081 }
+sub ERROR_CLUSTER_OWNER_NOT_IN_PREFLIST () { 5082 }
+sub ERROR_CLUSTER_DATABASE_SEQMISMATCH () { 5083 }
+sub ERROR_RESMON_INVALID_STATE () { 5084 }
+sub ERROR_CLUSTER_GUM_NOT_LOCKER () { 5085 }
+sub ERROR_QUORUM_DISK_NOT_FOUND () { 5086 }
+sub ERROR_DATABASE_BACKUP_CORRUPT () { 5087 }
+sub ERROR_CLUSTER_NODE_ALREADY_HAS_DFS_ROOT () { 5088 }
+sub ERROR_RESOURCE_PROPERTY_UNCHANGEABLE () { 5089 }
+sub ERROR_CLUSTER_MEMBERSHIP_INVALID_STATE () { 5890 }
+sub ERROR_CLUSTER_QUORUMLOG_NOT_FOUND () { 5891 }
+sub ERROR_CLUSTER_MEMBERSHIP_HALT () { 5892 }
+sub ERROR_CLUSTER_INSTANCE_ID_MISMATCH () { 5893 }
+sub ERROR_CLUSTER_NETWORK_NOT_FOUND_FOR_IP () { 5894 }
+sub ERROR_CLUSTER_PROPERTY_DATA_TYPE_MISMATCH () { 5895 }
+sub ERROR_CLUSTER_EVICT_WITHOUT_CLEANUP () { 5896 }
+sub ERROR_CLUSTER_PARAMETER_MISMATCH () { 5897 }
+sub ERROR_NODE_CANNOT_BE_CLUSTERED () { 5898 }
+sub ERROR_CLUSTER_WRONG_OS_VERSION () { 5899 }
+sub ERROR_CLUSTER_CANT_CREATE_DUP_CLUSTER_NAME () { 5900 }
+sub ERROR_CLUSCFG_ALREADY_COMMITTED () { 5901 }
+sub ERROR_CLUSCFG_ROLLBACK_FAILED () { 5902 }
+sub ERROR_CLUSCFG_SYSTEM_DISK_DRIVE_LETTER_CONFLICT () { 5903 }
+sub ERROR_CLUSTER_OLD_VERSION () { 5904 }
+sub ERROR_CLUSTER_MISMATCHED_COMPUTER_ACCT_NAME () { 5905 }
+sub ERROR_ENCRYPTION_FAILED () { 6000 }
+sub ERROR_DECRYPTION_FAILED () { 6001 }
+sub ERROR_FILE_ENCRYPTED () { 6002 }
+sub ERROR_NO_RECOVERY_POLICY () { 6003 }
+sub ERROR_NO_EFS () { 6004 }
+sub ERROR_WRONG_EFS () { 6005 }
+sub ERROR_NO_USER_KEYS () { 6006 }
+sub ERROR_FILE_NOT_ENCRYPTED () { 6007 }
+sub ERROR_NOT_EXPORT_FORMAT () { 6008 }
+sub ERROR_FILE_READ_ONLY () { 6009 }
+sub ERROR_DIR_EFS_DISALLOWED () { 6010 }
+sub ERROR_EFS_SERVER_NOT_TRUSTED () { 6011 }
+sub ERROR_BAD_RECOVERY_POLICY () { 6012 }
+sub ERROR_EFS_ALG_BLOB_TOO_BIG () { 6013 }
+sub ERROR_VOLUME_NOT_SUPPORT_EFS () { 6014 }
+sub ERROR_EFS_DISABLED () { 6015 }
+sub ERROR_EFS_VERSION_NOT_SUPPORT () { 6016 }
+sub ERROR_NO_BROWSER_SERVERS_FOUND () { 6118 }
+sub ERROR_CTX_WINSTATION_NAME_INVALID () { 7001 }
+sub ERROR_CTX_INVALID_PD () { 7002 }
+sub ERROR_CTX_PD_NOT_FOUND () { 7003 }
+sub ERROR_CTX_WD_NOT_FOUND () { 7004 }
+sub ERROR_CTX_CANNOT_MAKE_EVENTLOG_ENTRY () { 7005 }
+sub ERROR_CTX_SERVICE_NAME_COLLISION () { 7006 }
+sub ERROR_CTX_CLOSE_PENDING () { 7007 }
+sub ERROR_CTX_NO_OUTBUF () { 7008 }
+sub ERROR_CTX_MODEM_INF_NOT_FOUND () { 7009 }
+sub ERROR_CTX_INVALID_MODEMNAME () { 7010 }
+sub ERROR_CTX_MODEM_RESPONSE_ERROR () { 7011 }
+sub ERROR_CTX_MODEM_RESPONSE_TIMEOUT () { 7012 }
+sub ERROR_CTX_MODEM_RESPONSE_NO_CARRIER () { 7013 }
+sub ERROR_CTX_MODEM_RESPONSE_NO_DIALTONE () { 7014 }
+sub ERROR_CTX_MODEM_RESPONSE_BUSY () { 7015 }
+sub ERROR_CTX_MODEM_RESPONSE_VOICE () { 7016 }
+sub ERROR_CTX_TD_ERROR () { 7017 }
+sub ERROR_CTX_WINSTATION_NOT_FOUND () { 7022 }
+sub ERROR_CTX_WINSTATION_ALREADY_EXISTS () { 7023 }
+sub ERROR_CTX_WINSTATION_BUSY () { 7024 }
+sub ERROR_CTX_BAD_VIDEO_MODE () { 7025 }
+sub ERROR_CTX_GRAPHICS_INVALID () { 7035 }
+sub ERROR_CTX_LOGON_DISABLED () { 7037 }
+sub ERROR_CTX_NOT_CONSOLE () { 7038 }
+sub ERROR_CTX_CLIENT_QUERY_TIMEOUT () { 7040 }
+sub ERROR_CTX_CONSOLE_DISCONNECT () { 7041 }
+sub ERROR_CTX_CONSOLE_CONNECT () { 7042 }
+sub ERROR_CTX_SHADOW_DENIED () { 7044 }
+sub ERROR_CTX_WINSTATION_ACCESS_DENIED () { 7045 }
+sub ERROR_CTX_INVALID_WD () { 7049 }
+sub ERROR_CTX_SHADOW_INVALID () { 7050 }
+sub ERROR_CTX_SHADOW_DISABLED () { 7051 }
+sub ERROR_CTX_CLIENT_LICENSE_IN_USE () { 7052 }
+sub ERROR_CTX_CLIENT_LICENSE_NOT_SET () { 7053 }
+sub ERROR_CTX_LICENSE_NOT_AVAILABLE () { 7054 }
+sub ERROR_CTX_LICENSE_CLIENT_INVALID () { 7055 }
+sub ERROR_CTX_LICENSE_EXPIRED () { 7056 }
+sub ERROR_CTX_SHADOW_NOT_RUNNING () { 7057 }
+sub ERROR_CTX_SHADOW_ENDED_BY_MODE_CHANGE () { 7058 }
+sub ERROR_ACTIVATION_COUNT_EXCEEDED () { 7059 }
+sub ES_NUMBER () { 8192 }
+sub ERROR_DS_NOT_INSTALLED () { 8200 }
+sub ERROR_DS_MEMBERSHIP_EVALUATED_LOCALLY () { 8201 }
+sub ERROR_DS_NO_ATTRIBUTE_OR_VALUE () { 8202 }
+sub ERROR_DS_INVALID_ATTRIBUTE_SYNTAX () { 8203 }
+sub ERROR_DS_ATTRIBUTE_TYPE_UNDEFINED () { 8204 }
+sub ERROR_DS_ATTRIBUTE_OR_VALUE_EXISTS () { 8205 }
+sub ERROR_DS_BUSY () { 8206 }
+sub ERROR_DS_UNAVAILABLE () { 8207 }
+sub ERROR_DS_NO_RIDS_ALLOCATED () { 8208 }
+sub ERROR_DS_NO_MORE_RIDS () { 8209 }
+sub ERROR_DS_INCORRECT_ROLE_OWNER () { 8210 }
+sub ERROR_DS_RIDMGR_INIT_ERROR () { 8211 }
+sub ERROR_DS_OBJ_CLASS_VIOLATION () { 8212 }
+sub ERROR_DS_CANT_ON_NON_LEAF () { 8213 }
+sub ERROR_DS_CANT_ON_RDN () { 8214 }
+sub ERROR_DS_CANT_MOD_OBJ_CLASS () { 8215 }
+sub ERROR_DS_CROSS_DOM_MOVE_ERROR () { 8216 }
+sub ERROR_DS_GC_NOT_AVAILABLE () { 8217 }
+sub ERROR_SHARED_POLICY () { 8218 }
+sub ERROR_POLICY_OBJECT_NOT_FOUND () { 8219 }
+sub ERROR_POLICY_ONLY_IN_DS () { 8220 }
+sub ERROR_PROMOTION_ACTIVE () { 8221 }
+sub ERROR_NO_PROMOTION_ACTIVE () { 8222 }
+sub ERROR_DS_OPERATIONS_ERROR () { 8224 }
+sub ERROR_DS_PROTOCOL_ERROR () { 8225 }
+sub ERROR_DS_TIMELIMIT_EXCEEDED () { 8226 }
+sub ERROR_DS_SIZELIMIT_EXCEEDED () { 8227 }
+sub ERROR_DS_ADMIN_LIMIT_EXCEEDED () { 8228 }
+sub ERROR_DS_COMPARE_FALSE () { 8229 }
+sub ERROR_DS_COMPARE_TRUE () { 8230 }
+sub ERROR_DS_AUTH_METHOD_NOT_SUPPORTED () { 8231 }
+sub ERROR_DS_STRONG_AUTH_REQUIRED () { 8232 }
+sub ERROR_DS_INAPPROPRIATE_AUTH () { 8233 }
+sub ERROR_DS_AUTH_UNKNOWN () { 8234 }
+sub ERROR_DS_REFERRAL () { 8235 }
+sub ERROR_DS_UNAVAILABLE_CRIT_EXTENSION () { 8236 }
+sub ERROR_DS_CONFIDENTIALITY_REQUIRED () { 8237 }
+sub ERROR_DS_INAPPROPRIATE_MATCHING () { 8238 }
+sub ERROR_DS_CONSTRAINT_VIOLATION () { 8239 }
+sub ERROR_DS_NO_SUCH_OBJECT () { 8240 }
+sub ERROR_DS_ALIAS_PROBLEM () { 8241 }
+sub ERROR_DS_INVALID_DN_SYNTAX () { 8242 }
+sub ERROR_DS_IS_LEAF () { 8243 }
+sub ERROR_DS_ALIAS_DEREF_PROBLEM () { 8244 }
+sub ERROR_DS_UNWILLING_TO_PERFORM () { 8245 }
+sub ERROR_DS_LOOP_DETECT () { 8246 }
+sub ERROR_DS_NAMING_VIOLATION () { 8247 }
+sub ERROR_DS_OBJECT_RESULTS_TOO_LARGE () { 8248 }
+sub ERROR_DS_AFFECTS_MULTIPLE_DSAS () { 8249 }
+sub ERROR_DS_SERVER_DOWN () { 8250 }
+sub ERROR_DS_LOCAL_ERROR () { 8251 }
+sub ERROR_DS_ENCODING_ERROR () { 8252 }
+sub ERROR_DS_DECODING_ERROR () { 8253 }
+sub ERROR_DS_FILTER_UNKNOWN () { 8254 }
+sub ERROR_DS_PARAM_ERROR () { 8255 }
+sub ERROR_DS_NOT_SUPPORTED () { 8256 }
+sub ERROR_DS_NO_RESULTS_RETURNED () { 8257 }
+sub ERROR_DS_CONTROL_NOT_FOUND () { 8258 }
+sub ERROR_DS_CLIENT_LOOP () { 8259 }
+sub ERROR_DS_REFERRAL_LIMIT_EXCEEDED () { 8260 }
+sub ERROR_DS_SORT_CONTROL_MISSING () { 8261 }
+sub ERROR_DS_OFFSET_RANGE_ERROR () { 8262 }
+sub ERROR_DS_ROOT_MUST_BE_NC () { 8301 }
+sub ERROR_DS_ADD_REPLICA_INHIBITED () { 8302 }
+sub ERROR_DS_ATT_NOT_DEF_IN_SCHEMA () { 8303 }
+sub ERROR_DS_MAX_OBJ_SIZE_EXCEEDED () { 8304 }
+sub ERROR_DS_OBJ_STRING_NAME_EXISTS () { 8305 }
+sub ERROR_DS_NO_RDN_DEFINED_IN_SCHEMA () { 8306 }
+sub ERROR_DS_RDN_DOESNT_MATCH_SCHEMA () { 8307 }
+sub ERROR_DS_NO_REQUESTED_ATTS_FOUND () { 8308 }
+sub ERROR_DS_USER_BUFFER_TO_SMALL () { 8309 }
+sub ERROR_DS_ATT_IS_NOT_ON_OBJ () { 8310 }
+sub ERROR_DS_ILLEGAL_MOD_OPERATION () { 8311 }
+sub ERROR_DS_OBJ_TOO_LARGE () { 8312 }
+sub ERROR_DS_BAD_INSTANCE_TYPE () { 8313 }
+sub ERROR_DS_MASTERDSA_REQUIRED () { 8314 }
+sub ERROR_DS_OBJECT_CLASS_REQUIRED () { 8315 }
+sub ERROR_DS_MISSING_REQUIRED_ATT () { 8316 }
+sub ERROR_DS_ATT_NOT_DEF_FOR_CLASS () { 8317 }
+sub ERROR_DS_ATT_ALREADY_EXISTS () { 8318 }
+sub ERROR_DS_CANT_ADD_ATT_VALUES () { 8320 }
+sub ERROR_DS_SINGLE_VALUE_CONSTRAINT () { 8321 }
+sub ERROR_DS_RANGE_CONSTRAINT () { 8322 }
+sub ERROR_DS_ATT_VAL_ALREADY_EXISTS () { 8323 }
+sub ERROR_DS_CANT_REM_MISSING_ATT () { 8324 }
+sub ERROR_DS_CANT_REM_MISSING_ATT_VAL () { 8325 }
+sub ERROR_DS_ROOT_CANT_BE_SUBREF () { 8326 }
+sub ERROR_DS_NO_CHAINING () { 8327 }
+sub ERROR_DS_NO_CHAINED_EVAL () { 8328 }
+sub ERROR_DS_NO_PARENT_OBJECT () { 8329 }
+sub ERROR_DS_PARENT_IS_AN_ALIAS () { 8330 }
+sub ERROR_DS_CANT_MIX_MASTER_AND_REPS () { 8331 }
+sub ERROR_DS_CHILDREN_EXIST () { 8332 }
+sub ERROR_DS_OBJ_NOT_FOUND () { 8333 }
+sub ERROR_DS_ALIASED_OBJ_MISSING () { 8334 }
+sub ERROR_DS_BAD_NAME_SYNTAX () { 8335 }
+sub ERROR_DS_ALIAS_POINTS_TO_ALIAS () { 8336 }
+sub ERROR_DS_CANT_DEREF_ALIAS () { 8337 }
+sub ERROR_DS_OUT_OF_SCOPE () { 8338 }
+sub ERROR_DS_OBJECT_BEING_REMOVED () { 8339 }
+sub ERROR_DS_CANT_DELETE_DSA_OBJ () { 8340 }
+sub ERROR_DS_GENERIC_ERROR () { 8341 }
+sub ERROR_DS_DSA_MUST_BE_INT_MASTER () { 8342 }
+sub ERROR_DS_CLASS_NOT_DSA () { 8343 }
+sub ERROR_DS_INSUFF_ACCESS_RIGHTS () { 8344 }
+sub ERROR_DS_ILLEGAL_SUPERIOR () { 8345 }
+sub ERROR_DS_ATTRIBUTE_OWNED_BY_SAM () { 8346 }
+sub ERROR_DS_NAME_TOO_MANY_PARTS () { 8347 }
+sub ERROR_DS_NAME_TOO_LONG () { 8348 }
+sub ERROR_DS_NAME_VALUE_TOO_LONG () { 8349 }
+sub ERROR_DS_NAME_UNPARSEABLE () { 8350 }
+sub ERROR_DS_NAME_TYPE_UNKNOWN () { 8351 }
+sub ERROR_DS_NOT_AN_OBJECT () { 8352 }
+sub ERROR_DS_SEC_DESC_TOO_SHORT () { 8353 }
+sub ERROR_DS_SEC_DESC_INVALID () { 8354 }
+sub ERROR_DS_NO_DELETED_NAME () { 8355 }
+sub ERROR_DS_SUBREF_MUST_HAVE_PARENT () { 8356 }
+sub ERROR_DS_NCNAME_MUST_BE_NC () { 8357 }
+sub ERROR_DS_CANT_ADD_SYSTEM_ONLY () { 8358 }
+sub ERROR_DS_CLASS_MUST_BE_CONCRETE () { 8359 }
+sub ERROR_DS_INVALID_DMD () { 8360 }
+sub ERROR_DS_OBJ_GUID_EXISTS () { 8361 }
+sub ERROR_DS_NOT_ON_BACKLINK () { 8362 }
+sub ERROR_DS_NO_CROSSREF_FOR_NC () { 8363 }
+sub ERROR_DS_SHUTTING_DOWN () { 8364 }
+sub ERROR_DS_UNKNOWN_OPERATION () { 8365 }
+sub ERROR_DS_INVALID_ROLE_OWNER () { 8366 }
+sub ERROR_DS_COULDNT_CONTACT_FSMO () { 8367 }
+sub ERROR_DS_CROSS_NC_DN_RENAME () { 8368 }
+sub ERROR_DS_CANT_MOD_SYSTEM_ONLY () { 8369 }
+sub ERROR_DS_REPLICATOR_ONLY () { 8370 }
+sub ERROR_DS_OBJ_CLASS_NOT_DEFINED () { 8371 }
+sub ERROR_DS_OBJ_CLASS_NOT_SUBCLASS () { 8372 }
+sub ERROR_DS_NAME_REFERENCE_INVALID () { 8373 }
+sub ERROR_DS_CROSS_REF_EXISTS () { 8374 }
+sub ERROR_DS_CANT_DEL_MASTER_CROSSREF () { 8375 }
+sub ERROR_DS_SUBTREE_NOTIFY_NOT_NC_HEAD () { 8376 }
+sub ERROR_DS_NOTIFY_FILTER_TOO_COMPLEX () { 8377 }
+sub ERROR_DS_DUP_RDN () { 8378 }
+sub ERROR_DS_DUP_OID () { 8379 }
+sub ERROR_DS_DUP_MAPI_ID () { 8380 }
+sub ERROR_DS_DUP_SCHEMA_ID_GUID () { 8381 }
+sub ERROR_DS_DUP_LDAP_DISPLAY_NAME () { 8382 }
+sub ERROR_DS_SEMANTIC_ATT_TEST () { 8383 }
+sub ERROR_DS_SYNTAX_MISMATCH () { 8384 }
+sub ERROR_DS_EXISTS_IN_MUST_HAVE () { 8385 }
+sub ERROR_DS_EXISTS_IN_MAY_HAVE () { 8386 }
+sub ERROR_DS_NONEXISTENT_MAY_HAVE () { 8387 }
+sub ERROR_DS_NONEXISTENT_MUST_HAVE () { 8388 }
+sub ERROR_DS_AUX_CLS_TEST_FAIL () { 8389 }
+sub ERROR_DS_NONEXISTENT_POSS_SUP () { 8390 }
+sub ERROR_DS_SUB_CLS_TEST_FAIL () { 8391 }
+sub ERROR_DS_BAD_RDN_ATT_ID_SYNTAX () { 8392 }
+sub ERROR_DS_EXISTS_IN_AUX_CLS () { 8393 }
+sub ERROR_DS_EXISTS_IN_SUB_CLS () { 8394 }
+sub ERROR_DS_EXISTS_IN_POSS_SUP () { 8395 }
+sub ERROR_DS_RECALCSCHEMA_FAILED () { 8396 }
+sub ERROR_DS_TREE_DELETE_NOT_FINISHED () { 8397 }
+sub ERROR_DS_CANT_DELETE () { 8398 }
+sub ERROR_DS_ATT_SCHEMA_REQ_ID () { 8399 }
+sub ERROR_DS_BAD_ATT_SCHEMA_SYNTAX () { 8400 }
+sub ERROR_DS_CANT_CACHE_ATT () { 8401 }
+sub ERROR_DS_CANT_CACHE_CLASS () { 8402 }
+sub ERROR_DS_CANT_REMOVE_ATT_CACHE () { 8403 }
+sub ERROR_DS_CANT_REMOVE_CLASS_CACHE () { 8404 }
+sub ERROR_DS_CANT_RETRIEVE_DN () { 8405 }
+sub ERROR_DS_MISSING_SUPREF () { 8406 }
+sub ERROR_DS_CANT_RETRIEVE_INSTANCE () { 8407 }
+sub ERROR_DS_CODE_INCONSISTENCY () { 8408 }
+sub ERROR_DS_DATABASE_ERROR () { 8409 }
+sub ERROR_DS_GOVERNSID_MISSING () { 8410 }
+sub ERROR_DS_MISSING_EXPECTED_ATT () { 8411 }
+sub ERROR_DS_NCNAME_MISSING_CR_REF () { 8412 }
+sub ERROR_DS_SECURITY_CHECKING_ERROR () { 8413 }
+sub ERROR_DS_SCHEMA_NOT_LOADED () { 8414 }
+sub ERROR_DS_SCHEMA_ALLOC_FAILED () { 8415 }
+sub ERROR_DS_ATT_SCHEMA_REQ_SYNTAX () { 8416 }
+sub ERROR_DS_GCVERIFY_ERROR () { 8417 }
+sub ERROR_DS_DRA_SCHEMA_MISMATCH () { 8418 }
+sub ERROR_DS_CANT_FIND_DSA_OBJ () { 8419 }
+sub ERROR_DS_CANT_FIND_EXPECTED_NC () { 8420 }
+sub ERROR_DS_CANT_FIND_NC_IN_CACHE () { 8421 }
+sub ERROR_DS_CANT_RETRIEVE_CHILD () { 8422 }
+sub ERROR_DS_SECURITY_ILLEGAL_MODIFY () { 8423 }
+sub ERROR_DS_CANT_REPLACE_HIDDEN_REC () { 8424 }
+sub ERROR_DS_BAD_HIERARCHY_FILE () { 8425 }
+sub ERROR_DS_BUILD_HIERARCHY_TABLE_FAILED () { 8426 }
+sub ERROR_DS_CONFIG_PARAM_MISSING () { 8427 }
+sub ERROR_DS_COUNTING_AB_INDICES_FAILED () { 8428 }
+sub ERROR_DS_HIERARCHY_TABLE_MALLOC_FAILED () { 8429 }
+sub ERROR_DS_INTERNAL_FAILURE () { 8430 }
+sub ERROR_DS_UNKNOWN_ERROR () { 8431 }
+sub ERROR_DS_ROOT_REQUIRES_CLASS_TOP () { 8432 }
+sub ERROR_DS_REFUSING_FSMO_ROLES () { 8433 }
+sub ERROR_DS_MISSING_FSMO_SETTINGS () { 8434 }
+sub ERROR_DS_UNABLE_TO_SURRENDER_ROLES () { 8435 }
+sub ERROR_DS_DRA_GENERIC () { 8436 }
+sub ERROR_DS_DRA_INVALID_PARAMETER () { 8437 }
+sub ERROR_DS_DRA_BUSY () { 8438 }
+sub ERROR_DS_DRA_BAD_DN () { 8439 }
+sub ERROR_DS_DRA_BAD_NC () { 8440 }
+sub ERROR_DS_DRA_DN_EXISTS () { 8441 }
+sub ERROR_DS_DRA_INTERNAL_ERROR () { 8442 }
+sub ERROR_DS_DRA_INCONSISTENT_DIT () { 8443 }
+sub ERROR_DS_DRA_CONNECTION_FAILED () { 8444 }
+sub ERROR_DS_DRA_BAD_INSTANCE_TYPE () { 8445 }
+sub ERROR_DS_DRA_OUT_OF_MEM () { 8446 }
+sub ERROR_DS_DRA_MAIL_PROBLEM () { 8447 }
+sub ERROR_DS_DRA_REF_ALREADY_EXISTS () { 8448 }
+sub ERROR_DS_DRA_REF_NOT_FOUND () { 8449 }
+sub ERROR_DS_DRA_OBJ_IS_REP_SOURCE () { 8450 }
+sub ERROR_DS_DRA_DB_ERROR () { 8451 }
+sub ERROR_DS_DRA_NO_REPLICA () { 8452 }
+sub ERROR_DS_DRA_ACCESS_DENIED () { 8453 }
+sub ERROR_DS_DRA_NOT_SUPPORTED () { 8454 }
+sub ERROR_DS_DRA_RPC_CANCELLED () { 8455 }
+sub ERROR_DS_DRA_SOURCE_DISABLED () { 8456 }
+sub ERROR_DS_DRA_SINK_DISABLED () { 8457 }
+sub ERROR_DS_DRA_NAME_COLLISION () { 8458 }
+sub ERROR_DS_DRA_SOURCE_REINSTALLED () { 8459 }
+sub ERROR_DS_DRA_MISSING_PARENT () { 8460 }
+sub ERROR_DS_DRA_PREEMPTED () { 8461 }
+sub ERROR_DS_DRA_ABANDON_SYNC () { 8462 }
+sub ERROR_DS_DRA_SHUTDOWN () { 8463 }
+sub ERROR_DS_DRA_INCOMPATIBLE_PARTIAL_SET () { 8464 }
+sub ERROR_DS_DRA_SOURCE_IS_PARTIAL_REPLICA () { 8465 }
+sub ERROR_DS_DRA_EXTN_CONNECTION_FAILED () { 8466 }
+sub ERROR_DS_INSTALL_SCHEMA_MISMATCH () { 8467 }
+sub ERROR_DS_DUP_LINK_ID () { 8468 }
+sub ERROR_DS_NAME_ERROR_RESOLVING () { 8469 }
+sub ERROR_DS_NAME_ERROR_NOT_FOUND () { 8470 }
+sub ERROR_DS_NAME_ERROR_NOT_UNIQUE () { 8471 }
+sub ERROR_DS_NAME_ERROR_NO_MAPPING () { 8472 }
+sub ERROR_DS_NAME_ERROR_DOMAIN_ONLY () { 8473 }
+sub ERROR_DS_NAME_ERROR_NO_SYNTACTICAL_MAPPING () { 8474 }
+sub ERROR_DS_CONSTRUCTED_ATT_MOD () { 8475 }
+sub ERROR_DS_WRONG_OM_OBJ_CLASS () { 8476 }
+sub ERROR_DS_DRA_REPL_PENDING () { 8477 }
+sub ERROR_DS_DS_REQUIRED () { 8478 }
+sub ERROR_DS_INVALID_LDAP_DISPLAY_NAME () { 8479 }
+sub ERROR_DS_NON_BASE_SEARCH () { 8480 }
+sub ERROR_DS_CANT_RETRIEVE_ATTS () { 8481 }
+sub ERROR_DS_BACKLINK_WITHOUT_LINK () { 8482 }
+sub ERROR_DS_EPOCH_MISMATCH () { 8483 }
+sub ERROR_DS_SRC_NAME_MISMATCH () { 8484 }
+sub ERROR_DS_SRC_AND_DST_NC_IDENTICAL () { 8485 }
+sub ERROR_DS_DST_NC_MISMATCH () { 8486 }
+sub ERROR_DS_NOT_AUTHORITIVE_FOR_DST_NC () { 8487 }
+sub ERROR_DS_SRC_GUID_MISMATCH () { 8488 }
+sub ERROR_DS_CANT_MOVE_DELETED_OBJECT () { 8489 }
+sub ERROR_DS_PDC_OPERATION_IN_PROGRESS () { 8490 }
+sub ERROR_DS_CROSS_DOMAIN_CLEANUP_REQD () { 8491 }
+sub ERROR_DS_ILLEGAL_XDOM_MOVE_OPERATION () { 8492 }
+sub ERROR_DS_CANT_WITH_ACCT_GROUP_MEMBERSHPS () { 8493 }
+sub ERROR_DS_NC_MUST_HAVE_NC_PARENT () { 8494 }
+sub ERROR_DS_CR_IMPOSSIBLE_TO_VALIDATE () { 8495 }
+sub ERROR_DS_DST_DOMAIN_NOT_NATIVE () { 8496 }
+sub ERROR_DS_MISSING_INFRASTRUCTURE_CONTAINER () { 8497 }
+sub ERROR_DS_CANT_MOVE_ACCOUNT_GROUP () { 8498 }
+sub ERROR_DS_CANT_MOVE_RESOURCE_GROUP () { 8499 }
+sub ERROR_DS_INVALID_SEARCH_FLAG () { 8500 }
+sub ERROR_DS_NO_TREE_DELETE_ABOVE_NC () { 8501 }
+sub ERROR_DS_COULDNT_LOCK_TREE_FOR_DELETE () { 8502 }
+sub ERROR_DS_COULDNT_IDENTIFY_OBJECTS_FOR_TREE_DELETE () { 8503 }
+sub ERROR_DS_SAM_INIT_FAILURE () { 8504 }
+sub ERROR_DS_SENSITIVE_GROUP_VIOLATION () { 8505 }
+sub ERROR_DS_CANT_MOD_PRIMARYGROUPID () { 8506 }
+sub ERROR_DS_ILLEGAL_BASE_SCHEMA_MOD () { 8507 }
+sub ERROR_DS_NONSAFE_SCHEMA_CHANGE () { 8508 }
+sub ERROR_DS_SCHEMA_UPDATE_DISALLOWED () { 8509 }
+sub ERROR_DS_CANT_CREATE_UNDER_SCHEMA () { 8510 }
+sub ERROR_DS_INSTALL_NO_SRC_SCH_VERSION () { 8511 }
+sub ERROR_DS_INSTALL_NO_SCH_VERSION_IN_INIFILE () { 8512 }
+sub ERROR_DS_INVALID_GROUP_TYPE () { 8513 }
+sub ERROR_DS_NO_NEST_GLOBALGROUP_IN_MIXEDDOMAIN () { 8514 }
+sub ERROR_DS_NO_NEST_LOCALGROUP_IN_MIXEDDOMAIN () { 8515 }
+sub ERROR_DS_GLOBAL_CANT_HAVE_LOCAL_MEMBER () { 8516 }
+sub ERROR_DS_GLOBAL_CANT_HAVE_UNIVERSAL_MEMBER () { 8517 }
+sub ERROR_DS_UNIVERSAL_CANT_HAVE_LOCAL_MEMBER () { 8518 }
+sub ERROR_DS_GLOBAL_CANT_HAVE_CROSSDOMAIN_MEMBER () { 8519 }
+sub ERROR_DS_LOCAL_CANT_HAVE_CROSSDOMAIN_LOCAL_MEMBER () { 8520 }
+sub ERROR_DS_HAVE_PRIMARY_MEMBERS () { 8521 }
+sub ERROR_DS_STRING_SD_CONVERSION_FAILED () { 8522 }
+sub ERROR_DS_NAMING_MASTER_GC () { 8523 }
+sub ERROR_DS_DNS_LOOKUP_FAILURE () { 8524 }
+sub ERROR_DS_COULDNT_UPDATE_SPNS () { 8525 }
+sub ERROR_DS_CANT_RETRIEVE_SD () { 8526 }
+sub ERROR_DS_KEY_NOT_UNIQUE () { 8527 }
+sub ERROR_DS_WRONG_LINKED_ATT_SYNTAX () { 8528 }
+sub ERROR_DS_SAM_NEED_BOOTKEY_PASSWORD () { 8529 }
+sub ERROR_DS_SAM_NEED_BOOTKEY_FLOPPY () { 8530 }
+sub ERROR_DS_CANT_START () { 8531 }
+sub ERROR_DS_INIT_FAILURE () { 8532 }
+sub ERROR_DS_NO_PKT_PRIVACY_ON_CONNECTION () { 8533 }
+sub ERROR_DS_SOURCE_DOMAIN_IN_FOREST () { 8534 }
+sub ERROR_DS_DESTINATION_DOMAIN_NOT_IN_FOREST () { 8535 }
+sub ERROR_DS_DESTINATION_AUDITING_NOT_ENABLED () { 8536 }
+sub ERROR_DS_CANT_FIND_DC_FOR_SRC_DOMAIN () { 8537 }
+sub ERROR_DS_SRC_OBJ_NOT_GROUP_OR_USER () { 8538 }
+sub ERROR_DS_SRC_SID_EXISTS_IN_FOREST () { 8539 }
+sub ERROR_DS_SRC_AND_DST_OBJECT_CLASS_MISMATCH () { 8540 }
+sub ERROR_SAM_INIT_FAILURE () { 8541 }
+sub ERROR_DS_DRA_SCHEMA_INFO_SHIP () { 8542 }
+sub ERROR_DS_DRA_SCHEMA_CONFLICT () { 8543 }
+sub ERROR_DS_DRA_EARLIER_SCHEMA_CONFLICT () { 8544 }
+sub ERROR_DS_DRA_OBJ_NC_MISMATCH () { 8545 }
+sub ERROR_DS_NC_STILL_HAS_DSAS () { 8546 }
+sub ERROR_DS_GC_REQUIRED () { 8547 }
+sub ERROR_DS_LOCAL_MEMBER_OF_LOCAL_ONLY () { 8548 }
+sub ERROR_DS_NO_FPO_IN_UNIVERSAL_GROUPS () { 8549 }
+sub ERROR_DS_CANT_ADD_TO_GC () { 8550 }
+sub ERROR_DS_NO_CHECKPOINT_WITH_PDC () { 8551 }
+sub ERROR_DS_SOURCE_AUDITING_NOT_ENABLED () { 8552 }
+sub ERROR_DS_CANT_CREATE_IN_NONDOMAIN_NC () { 8553 }
+sub ERROR_DS_INVALID_NAME_FOR_SPN () { 8554 }
+sub ERROR_DS_FILTER_USES_CONTRUCTED_ATTRS () { 8555 }
+sub ERROR_DS_UNICODEPWD_NOT_IN_QUOTES () { 8556 }
+sub ERROR_DS_MACHINE_ACCOUNT_QUOTA_EXCEEDED () { 8557 }
+sub ERROR_DS_MUST_BE_RUN_ON_DST_DC () { 8558 }
+sub ERROR_DS_SRC_DC_MUST_BE_SP4_OR_GREATER () { 8559 }
+sub ERROR_DS_CANT_TREE_DELETE_CRITICAL_OBJ () { 8560 }
+sub ERROR_DS_INIT_FAILURE_CONSOLE () { 8561 }
+sub ERROR_DS_SAM_INIT_FAILURE_CONSOLE () { 8562 }
+sub ERROR_DS_FOREST_VERSION_TOO_HIGH () { 8563 }
+sub ERROR_DS_DOMAIN_VERSION_TOO_HIGH () { 8564 }
+sub ERROR_DS_FOREST_VERSION_TOO_LOW () { 8565 }
+sub ERROR_DS_DOMAIN_VERSION_TOO_LOW () { 8566 }
+sub ERROR_DS_INCOMPATIBLE_VERSION () { 8567 }
+sub ERROR_DS_LOW_DSA_VERSION () { 8568 }
+sub ERROR_DS_NO_BEHAVIOR_VERSION_IN_MIXEDDOMAIN () { 8569 }
+sub ERROR_DS_NOT_SUPPORTED_SORT_ORDER () { 8570 }
+sub ERROR_DS_NAME_NOT_UNIQUE () { 8571 }
+sub ERROR_DS_MACHINE_ACCOUNT_CREATED_PRENT4 () { 8572 }
+sub ERROR_DS_OUT_OF_VERSION_STORE () { 8573 }
+sub ERROR_DS_INCOMPATIBLE_CONTROLS_USED () { 8574 }
+sub ERROR_DS_NO_REF_DOMAIN () { 8575 }
+sub ERROR_DS_RESERVED_LINK_ID () { 8576 }
+sub ERROR_DS_LINK_ID_NOT_AVAILABLE () { 8577 }
+sub ERROR_DS_AG_CANT_HAVE_UNIVERSAL_MEMBER () { 8578 }
+sub ERROR_DS_MODIFYDN_DISALLOWED_BY_INSTANCE_TYPE () { 8579 }
+sub ERROR_DS_NO_OBJECT_MOVE_IN_SCHEMA_NC () { 8580 }
+sub ERROR_DS_MODIFYDN_DISALLOWED_BY_FLAG () { 8581 }
+sub ERROR_DS_MODIFYDN_WRONG_GRANDPARENT () { 8582 }
+sub ERROR_DS_NAME_ERROR_TRUST_REFERRAL () { 8583 }
+sub ERROR_NOT_SUPPORTED_ON_STANDARD_SERVER () { 8584 }
+sub ERROR_DS_CANT_ACCESS_REMOTE_PART_OF_AD () { 8585 }
+sub ERROR_DS_CR_IMPOSSIBLE_TO_VALIDATE_V2 () { 8586 }
+sub ERROR_DS_THREAD_LIMIT_EXCEEDED () { 8587 }
+sub ERROR_DS_NOT_CLOSEST () { 8588 }
+sub ERROR_DS_CANT_DERIVE_SPN_WITHOUT_SERVER_REF () { 8589 }
+sub ERROR_DS_SINGLE_USER_MODE_FAILED () { 8590 }
+sub ERROR_DS_NTDSCRIPT_SYNTAX_ERROR () { 8591 }
+sub ERROR_DS_NTDSCRIPT_PROCESS_ERROR () { 8592 }
+sub ERROR_DS_DIFFERENT_REPL_EPOCHS () { 8593 }
+sub ERROR_DS_DRS_EXTENSIONS_CHANGED () { 8594 }
+sub ERROR_DS_REPLICA_SET_CHANGE_NOT_ALLOWED_ON_DISABLED_CR () { 8595 }
+sub ERROR_DS_NO_MSDS_INTID () { 8596 }
+sub ERROR_DS_DUP_MSDS_INTID () { 8597 }
+sub ERROR_DS_EXISTS_IN_RDNATTID () { 8598 }
+sub ERROR_DS_AUTHORIZATION_FAILED () { 8599 }
+sub ERROR_DS_INVALID_SCRIPT () { 8600 }
+sub ERROR_DS_REMOTE_CROSSREF_OP_FAILED () { 8601 }
+sub ERROR_DS_CROSS_REF_BUSY () { 8602 }
+sub ERROR_DS_CANT_DERIVE_SPN_FOR_DELETED_DOMAIN () { 8603 }
+sub ERROR_DS_CANT_DEMOTE_WITH_WRITEABLE_NC () { 8604 }
+sub ERROR_DS_DUPLICATE_ID_FOUND () { 8605 }
+sub ERROR_DS_INSUFFICIENT_ATTR_TO_CREATE_OBJECT () { 8606 }
+sub ERROR_DS_GROUP_CONVERSION_ERROR () { 8607 }
+sub ERROR_DS_CANT_MOVE_APP_BASIC_GROUP () { 8608 }
+sub ERROR_DS_CANT_MOVE_APP_QUERY_GROUP () { 8609 }
+sub ERROR_DS_ROLE_NOT_VERIFIED () { 8610 }
+sub ERROR_DS_WKO_CONTAINER_CANNOT_BE_SPECIAL () { 8611 }
+sub ERROR_DS_DOMAIN_RENAME_IN_PROGRESS () { 8612 }
+sub ERROR_DS_EXISTING_AD_CHILD_NC () { 8613 }
+sub EWOULDBLOCK () { 10035 }
+sub EINPROGRESS () { 10036 }
+sub EALREADY () { 10037 }
+sub ENOTSOCK () { 10038 }
+sub EDESTADDRREQ () { 10039 }
+sub EMSGSIZE () { 10040 }
+sub EPROTOTYPE () { 10041 }
+sub ENOPROTOOPT () { 10042 }
+sub EPROTONOSUPPORT () { 10043 }
+sub ESOCKTNOSUPPORT () { 10044 }
+sub EOPNOTSUPP () { 10045 }
+sub EPFNOSUPPORT () { 10046 }
+sub EAFNOSUPPORT () { 10047 }
+sub EADDRINUSE () { 10048 }
+sub EADDRNOTAVAIL () { 10049 }
+sub ENETDOWN () { 10050 }
+sub ENETUNREACH () { 10051 }
+sub ENETRESET () { 10052 }
+sub ECONNABORTED () { 10053 }
+sub ECONNRESET () { 10054 }
+sub ENOBUFS () { 10055 }
+sub EISCONN () { 10056 }
+sub ENOTCONN () { 10057 }
+sub ESHUTDOWN () { 10058 }
+sub ETOOMANYREFS () { 10059 }
+sub ETIMEDOUT () { 10060 }
+sub ECONNREFUSED () { 10061 }
+sub ELOOP () { 10062 }
+sub EHOSTDOWN () { 10064 }
+sub EHOSTUNREACH () { 10065 }
+sub EPROCLIM () { 10067 }
+sub EUSERS () { 10068 }
+sub EDQUOT () { 10069 }
+sub ESTALE () { 10070 }
+sub EREMOTE () { 10071 }
+sub EDISCON () { 10101 }
+sub ENOMORE () { 10102 }
+sub ECANCELLED () { 10103 }
+sub EINVALIDPROCTABLE () { 10104 }
+sub EINVALIDPROVIDER () { 10105 }
+sub EPROVIDERFAILEDINIT () { 10106 }
+sub EREFUSED () { 10112 }
+sub ERROR_IPSEC_QM_POLICY_EXISTS () { 13000 }
+sub ERROR_IPSEC_QM_POLICY_NOT_FOUND () { 13001 }
+sub ERROR_IPSEC_QM_POLICY_IN_USE () { 13002 }
+sub ERROR_IPSEC_MM_POLICY_EXISTS () { 13003 }
+sub ERROR_IPSEC_MM_POLICY_NOT_FOUND () { 13004 }
+sub ERROR_IPSEC_MM_POLICY_IN_USE () { 13005 }
+sub ERROR_IPSEC_MM_FILTER_EXISTS () { 13006 }
+sub ERROR_IPSEC_MM_FILTER_NOT_FOUND () { 13007 }
+sub ERROR_IPSEC_TRANSPORT_FILTER_EXISTS () { 13008 }
+sub ERROR_IPSEC_TRANSPORT_FILTER_NOT_FOUND () { 13009 }
+sub ERROR_IPSEC_MM_AUTH_EXISTS () { 13010 }
+sub ERROR_IPSEC_MM_AUTH_NOT_FOUND () { 13011 }
+sub ERROR_IPSEC_MM_AUTH_IN_USE () { 13012 }
+sub ERROR_IPSEC_DEFAULT_MM_POLICY_NOT_FOUND () { 13013 }
+sub ERROR_IPSEC_DEFAULT_MM_AUTH_NOT_FOUND () { 13014 }
+sub ERROR_IPSEC_DEFAULT_QM_POLICY_NOT_FOUND () { 13015 }
+sub ERROR_IPSEC_TUNNEL_FILTER_EXISTS () { 13016 }
+sub ERROR_IPSEC_TUNNEL_FILTER_NOT_FOUND () { 13017 }
+sub ERROR_IPSEC_MM_FILTER_PENDING_DELETION () { 13018 }
+sub ERROR_IPSEC_TRANSPORT_FILTER_PENDING_DELETION () { 13019 }
+sub ERROR_IPSEC_TUNNEL_FILTER_PENDING_DELETION () { 13020 }
+sub ERROR_IPSEC_MM_POLICY_PENDING_DELETION () { 13021 }
+sub ERROR_IPSEC_MM_AUTH_PENDING_DELETION () { 13022 }
+sub ERROR_IPSEC_QM_POLICY_PENDING_DELETION () { 13023 }
+sub ERROR_IPSEC_IKE_AUTH_FAIL () { 13801 }
+sub ERROR_IPSEC_IKE_ATTRIB_FAIL () { 13802 }
+sub ERROR_IPSEC_IKE_NEGOTIATION_PENDING () { 13803 }
+sub ERROR_IPSEC_IKE_GENERAL_PROCESSING_ERROR () { 13804 }
+sub ERROR_IPSEC_IKE_TIMED_OUT () { 13805 }
+sub ERROR_IPSEC_IKE_NO_CERT () { 13806 }
+sub ERROR_IPSEC_IKE_SA_DELETED () { 13807 }
+sub ERROR_IPSEC_IKE_SA_REAPED () { 13808 }
+sub ERROR_IPSEC_IKE_MM_ACQUIRE_DROP () { 13809 }
+sub ERROR_IPSEC_IKE_QM_ACQUIRE_DROP () { 13810 }
+sub ERROR_IPSEC_IKE_QUEUE_DROP_MM () { 13811 }
+sub ERROR_IPSEC_IKE_QUEUE_DROP_NO_MM () { 13812 }
+sub ERROR_IPSEC_IKE_DROP_NO_RESPONSE () { 13813 }
+sub ERROR_IPSEC_IKE_MM_DELAY_DROP () { 13814 }
+sub ERROR_IPSEC_IKE_QM_DELAY_DROP () { 13815 }
+sub ERROR_IPSEC_IKE_ERROR () { 13816 }
+sub ERROR_IPSEC_IKE_CRL_FAILED () { 13817 }
+sub ERROR_IPSEC_IKE_INVALID_KEY_USAGE () { 13818 }
+sub ERROR_IPSEC_IKE_INVALID_CERT_TYPE () { 13819 }
+sub ERROR_IPSEC_IKE_NO_PRIVATE_KEY () { 13820 }
+sub ERROR_IPSEC_IKE_DH_FAIL () { 13822 }
+sub ERROR_IPSEC_IKE_INVALID_HEADER () { 13824 }
+sub ERROR_IPSEC_IKE_NO_POLICY () { 13825 }
+sub ERROR_IPSEC_IKE_INVALID_SIGNATURE () { 13826 }
+sub ERROR_IPSEC_IKE_KERBEROS_ERROR () { 13827 }
+sub ERROR_IPSEC_IKE_NO_PUBLIC_KEY () { 13828 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR () { 13829 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_SA () { 13830 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_PROP () { 13831 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_TRANS () { 13832 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_KE () { 13833 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_ID () { 13834 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_CERT () { 13835 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_CERT_REQ () { 13836 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_HASH () { 13837 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_SIG () { 13838 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_NONCE () { 13839 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_NOTIFY () { 13840 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_DELETE () { 13841 }
+sub ERROR_IPSEC_IKE_PROCESS_ERR_VENDOR () { 13842 }
+sub ERROR_IPSEC_IKE_INVALID_PAYLOAD () { 13843 }
+sub ERROR_IPSEC_IKE_LOAD_SOFT_SA () { 13844 }
+sub ERROR_IPSEC_IKE_SOFT_SA_TORN_DOWN () { 13845 }
+sub ERROR_IPSEC_IKE_INVALID_COOKIE () { 13846 }
+sub ERROR_IPSEC_IKE_NO_PEER_CERT () { 13847 }
+sub ERROR_IPSEC_IKE_PEER_CRL_FAILED () { 13848 }
+sub ERROR_IPSEC_IKE_POLICY_CHANGE () { 13849 }
+sub ERROR_IPSEC_IKE_NO_MM_POLICY () { 13850 }
+sub ERROR_IPSEC_IKE_NOTCBPRIV () { 13851 }
+sub ERROR_IPSEC_IKE_SECLOADFAIL () { 13852 }
+sub ERROR_IPSEC_IKE_FAILSSPINIT () { 13853 }
+sub ERROR_IPSEC_IKE_FAILQUERYSSP () { 13854 }
+sub ERROR_IPSEC_IKE_SRVACQFAIL () { 13855 }
+sub ERROR_IPSEC_IKE_SRVQUERYCRED () { 13856 }
+sub ERROR_IPSEC_IKE_GETSPIFAIL () { 13857 }
+sub ERROR_IPSEC_IKE_INVALID_FILTER () { 13858 }
+sub ERROR_IPSEC_IKE_OUT_OF_MEMORY () { 13859 }
+sub ERROR_IPSEC_IKE_ADD_UPDATE_KEY_FAILED () { 13860 }
+sub ERROR_IPSEC_IKE_INVALID_POLICY () { 13861 }
+sub ERROR_IPSEC_IKE_UNKNOWN_DOI () { 13862 }
+sub ERROR_IPSEC_IKE_INVALID_SITUATION () { 13863 }
+sub ERROR_IPSEC_IKE_DH_FAILURE () { 13864 }
+sub ERROR_IPSEC_IKE_INVALID_GROUP () { 13865 }
+sub ERROR_IPSEC_IKE_ENCRYPT () { 13866 }
+sub ERROR_IPSEC_IKE_DECRYPT () { 13867 }
+sub ERROR_IPSEC_IKE_POLICY_MATCH () { 13868 }
+sub ERROR_IPSEC_IKE_UNSUPPORTED_ID () { 13869 }
+sub ERROR_IPSEC_IKE_INVALID_HASH () { 13870 }
+sub ERROR_IPSEC_IKE_INVALID_HASH_ALG () { 13871 }
+sub ERROR_IPSEC_IKE_INVALID_HASH_SIZE () { 13872 }
+sub ERROR_IPSEC_IKE_INVALID_ENCRYPT_ALG () { 13873 }
+sub ERROR_IPSEC_IKE_INVALID_AUTH_ALG () { 13874 }
+sub ERROR_IPSEC_IKE_INVALID_SIG () { 13875 }
+sub ERROR_IPSEC_IKE_LOAD_FAILED () { 13876 }
+sub ERROR_IPSEC_IKE_RPC_DELETE () { 13877 }
+sub ERROR_IPSEC_IKE_BENIGN_REINIT () { 13878 }
+sub ERROR_IPSEC_IKE_INVALID_RESPONDER_LIFETIME_NOTIFY () { 13879 }
+sub ERROR_IPSEC_IKE_INVALID_CERT_KEYLEN () { 13881 }
+sub ERROR_IPSEC_IKE_MM_LIMIT () { 13882 }
+sub ERROR_IPSEC_IKE_NEGOTIATION_DISABLED () { 13883 }
+sub ERROR_IPSEC_IKE_NEG_STATUS_END () { 13884 }
+sub ERROR_SXS_SECTION_NOT_FOUND () { 14000 }
+sub ERROR_SXS_CANT_GEN_ACTCTX () { 14001 }
+sub ERROR_SXS_INVALID_ACTCTXDATA_FORMAT () { 14002 }
+sub ERROR_SXS_ASSEMBLY_NOT_FOUND () { 14003 }
+sub ERROR_SXS_MANIFEST_FORMAT_ERROR () { 14004 }
+sub ERROR_SXS_MANIFEST_PARSE_ERROR () { 14005 }
+sub ERROR_SXS_ACTIVATION_CONTEXT_DISABLED () { 14006 }
+sub ERROR_SXS_KEY_NOT_FOUND () { 14007 }
+sub ERROR_SXS_VERSION_CONFLICT () { 14008 }
+sub ERROR_SXS_WRONG_SECTION_TYPE () { 14009 }
+sub ERROR_SXS_THREAD_QUERIES_DISABLED () { 14010 }
+sub ERROR_SXS_PROCESS_DEFAULT_ALREADY_SET () { 14011 }
+sub ERROR_SXS_UNKNOWN_ENCODING_GROUP () { 14012 }
+sub ERROR_SXS_UNKNOWN_ENCODING () { 14013 }
+sub ERROR_SXS_INVALID_XML_NAMESPACE_URI () { 14014 }
+sub ERROR_SXS_ROOT_MANIFEST_DEPENDENCY_NOT_INSTALLED () { 14015 }
+sub ERROR_SXS_LEAF_MANIFEST_DEPENDENCY_NOT_INSTALLED () { 14016 }
+sub ERROR_SXS_INVALID_ASSEMBLY_IDENTITY_ATTRIBUTE () { 14017 }
+sub ERROR_SXS_MANIFEST_MISSING_REQUIRED_DEFAULT_NAMESPACE () { 14018 }
+sub ERROR_SXS_MANIFEST_INVALID_REQUIRED_DEFAULT_NAMESPACE () { 14019 }
+sub ERROR_SXS_PRIVATE_MANIFEST_CROSS_PATH_WITH_REPARSE_POINT () { 14020 }
+sub ERROR_SXS_DUPLICATE_DLL_NAME () { 14021 }
+sub ERROR_SXS_DUPLICATE_WINDOWCLASS_NAME () { 14022 }
+sub ERROR_SXS_DUPLICATE_CLSID () { 14023 }
+sub ERROR_SXS_DUPLICATE_IID () { 14024 }
+sub ERROR_SXS_DUPLICATE_TLBID () { 14025 }
+sub ERROR_SXS_DUPLICATE_PROGID () { 14026 }
+sub ERROR_SXS_DUPLICATE_ASSEMBLY_NAME () { 14027 }
+sub ERROR_SXS_FILE_HASH_MISMATCH () { 14028 }
+sub ERROR_SXS_POLICY_PARSE_ERROR () { 14029 }
+sub ERROR_SXS_XML_E_MISSINGQUOTE () { 14030 }
+sub ERROR_SXS_XML_E_COMMENTSYNTAX () { 14031 }
+sub ERROR_SXS_XML_E_BADSTARTNAMECHAR () { 14032 }
+sub ERROR_SXS_XML_E_BADNAMECHAR () { 14033 }
+sub ERROR_SXS_XML_E_BADCHARINSTRING () { 14034 }
+sub ERROR_SXS_XML_E_XMLDECLSYNTAX () { 14035 }
+sub ERROR_SXS_XML_E_BADCHARDATA () { 14036 }
+sub ERROR_SXS_XML_E_MISSINGWHITESPACE () { 14037 }
+sub ERROR_SXS_XML_E_EXPECTINGTAGEND () { 14038 }
+sub ERROR_SXS_XML_E_MISSINGSEMICOLON () { 14039 }
+sub ERROR_SXS_XML_E_UNBALANCEDPAREN () { 14040 }
+sub ERROR_SXS_XML_E_INTERNALERROR () { 14041 }
+sub ERROR_SXS_XML_E_UNEXPECTED_WHITESPACE () { 14042 }
+sub ERROR_SXS_XML_E_INCOMPLETE_ENCODING () { 14043 }
+sub ERROR_SXS_XML_E_MISSING_PAREN () { 14044 }
+sub ERROR_SXS_XML_E_EXPECTINGCLOSEQUOTE () { 14045 }
+sub ERROR_SXS_XML_E_MULTIPLE_COLONS () { 14046 }
+sub ERROR_SXS_XML_E_INVALID_DECIMAL () { 14047 }
+sub ERROR_SXS_XML_E_INVALID_HEXIDECIMAL () { 14048 }
+sub ERROR_SXS_XML_E_INVALID_UNICODE () { 14049 }
+sub ERROR_SXS_XML_E_WHITESPACEORQUESTIONMARK () { 14050 }
+sub ERROR_SXS_XML_E_UNEXPECTEDENDTAG () { 14051 }
+sub ERROR_SXS_XML_E_UNCLOSEDTAG () { 14052 }
+sub ERROR_SXS_XML_E_DUPLICATEATTRIBUTE () { 14053 }
+sub ERROR_SXS_XML_E_MULTIPLEROOTS () { 14054 }
+sub ERROR_SXS_XML_E_INVALIDATROOTLEVEL () { 14055 }
+sub ERROR_SXS_XML_E_BADXMLDECL () { 14056 }
+sub ERROR_SXS_XML_E_MISSINGROOT () { 14057 }
+sub ERROR_SXS_XML_E_UNEXPECTEDEOF () { 14058 }
+sub ERROR_SXS_XML_E_BADPEREFINSUBSET () { 14059 }
+sub ERROR_SXS_XML_E_UNCLOSEDSTARTTAG () { 14060 }
+sub ERROR_SXS_XML_E_UNCLOSEDENDTAG () { 14061 }
+sub ERROR_SXS_XML_E_UNCLOSEDSTRING () { 14062 }
+sub ERROR_SXS_XML_E_UNCLOSEDCOMMENT () { 14063 }
+sub ERROR_SXS_XML_E_UNCLOSEDDECL () { 14064 }
+sub ERROR_SXS_XML_E_UNCLOSEDCDATA () { 14065 }
+sub ERROR_SXS_XML_E_RESERVEDNAMESPACE () { 14066 }
+sub ERROR_SXS_XML_E_INVALIDENCODING () { 14067 }
+sub ERROR_SXS_XML_E_INVALIDSWITCH () { 14068 }
+sub ERROR_SXS_XML_E_BADXMLCASE () { 14069 }
+sub ERROR_SXS_XML_E_INVALID_STANDALONE () { 14070 }
+sub ERROR_SXS_XML_E_UNEXPECTED_STANDALONE () { 14071 }
+sub ERROR_SXS_XML_E_INVALID_VERSION () { 14072 }
+sub ERROR_SXS_XML_E_MISSINGEQUALS () { 14073 }
+sub ERROR_SXS_PROTECTION_RECOVERY_FAILED () { 14074 }
+sub ERROR_SXS_PROTECTION_PUBLIC_KEY_TOO_SHORT () { 14075 }
+sub ERROR_SXS_PROTECTION_CATALOG_NOT_VALID () { 14076 }
+sub ERROR_SXS_UNTRANSLATABLE_HRESULT () { 14077 }
+sub ERROR_SXS_PROTECTION_CATALOG_FILE_MISSING () { 14078 }
+sub ERROR_SXS_MISSING_ASSEMBLY_IDENTITY_ATTRIBUTE () { 14079 }
+sub ERROR_SXS_INVALID_ASSEMBLY_IDENTITY_ATTRIBUTE_NAME () { 14080 }
+sub EC_USEFONTINFO () { 65535 }
+sub EMBDHLP_DELAYCREATE () { 65536 }
+sub ENUM_S_FIRST () { 262576 }
+sub ENUM_S_LAST () { 262591 }
+sub EVENT_ALL_ACCESS () { 2031619 }
+sub ERROR_SEVERITY_INFORMATIONAL () { 1073741824 }
+sub ENHMETA_SIGNATURE () { 1179469088 }
+sub EPS_SIGNATURE () { 1179865157 }
+sub ENDSESSION_LOGOFF () { -2147483648 }
+sub ENHMETA_STOCK_OBJECT () { -2147483648 }
+sub ES_CONTINUOUS () { -2147483648 }
+sub ERROR_SEVERITY_WARNING () { -2147483648 }
+sub EXCEPTION_GUARD_PAGE () { -2147483647 }
+sub EXCEPTION_DATATYPE_MISALIGNMENT () { -2147483646 }
+sub EXCEPTION_BREAKPOINT () { -2147483645 }
+sub EXCEPTION_SINGLE_STEP () { -2147483644 }
+sub E_PENDING () { -2147483638 }
+sub E_NOTIMPL () { -2147467263 }
+sub E_NOINTERFACE () { -2147467262 }
+sub E_POINTER () { -2147467261 }
+sub E_ABORT () { -2147467260 }
+sub E_FAIL () { -2147467259 }
+sub E_UNEXPECTED () { -2147418113 }
+sub E_DRAW () { -2147221184 }
+sub ENUM_E_FIRST () { -2147221072 }
+sub ENUM_E_LAST () { -2147221057 }
+sub E_ACCESSDENIED () { -2147024891 }
+sub E_HANDLE () { -2147024890 }
+sub E_OUTOFMEMORY () { -2147024882 }
+sub E_INVALIDARG () { -2147024809 }
+sub ERROR_SEVERITY_ERROR () { -1073741824 }
+sub EXCEPTION_ACCESS_VIOLATION () { -1073741819 }
+sub EXCEPTION_IN_PAGE_ERROR () { -1073741818 }
+sub EXCEPTION_INVALID_HANDLE () { -1073741816 }
+sub EXCEPTION_ILLEGAL_INSTRUCTION () { -1073741795 }
+sub EXCEPTION_NONCONTINUABLE_EXCEPTION () { -1073741787 }
+sub EXCEPTION_INVALID_DISPOSITION () { -1073741786 }
+sub EXCEPTION_ARRAY_BOUNDS_EXCEEDED () { -1073741684 }
+sub EXCEPTION_FLT_DENORMAL_OPERAND () { -1073741683 }
+sub EXCEPTION_FLT_DIVIDE_BY_ZERO () { -1073741682 }
+sub EXCEPTION_FLT_INEXACT_RESULT () { -1073741681 }
+sub EXCEPTION_FLT_INVALID_OPERATION () { -1073741680 }
+sub EXCEPTION_FLT_OVERFLOW () { -1073741679 }
+sub EXCEPTION_FLT_STACK_CHECK () { -1073741678 }
+sub EXCEPTION_FLT_UNDERFLOW () { -1073741677 }
+sub EXCEPTION_INT_DIVIDE_BY_ZERO () { -1073741676 }
+sub EXCEPTION_INT_OVERFLOW () { -1073741675 }
+sub EXCEPTION_PRIV_INSTRUCTION () { -1073741674 }
+sub EXCEPTION_STACK_OVERFLOW () { -1073741571 }
+
+sub TIEHASH { bless [] }
+
+sub FETCH {
+ my ($self, $errname) = @_;
+ my $proto = prototype("Errno::$errname");
+ my $errno = "";
+ if (defined($proto) && $proto eq "") {
+ no strict 'refs';
+ $errno = &$errname;
+ $errno = 0 unless $! == $errno;
+ }
+ return $errno;
+}
+
+sub STORE {
+ require Carp;
+ Carp::confess("ERRNO hash is read only!");
+}
+
+*CLEAR = \&STORE;
+*DELETE = \&STORE;
+
+sub NEXTKEY {
+ my($k,$v);
+ while(($k,$v) = each %Errno::) {
+ my $proto = prototype("Errno::$k");
+ last if (defined($proto) && $proto eq "");
+ }
+ $k
+}
+
+sub FIRSTKEY {
+ my $s = scalar keys %Errno::; # initialize iterator
+ goto &NEXTKEY;
+}
+
+sub EXISTS {
+ my ($self, $errname) = @_;
+ my $r = ref $errname;
+ my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef;
+ defined($proto) && $proto eq "";
+}
+
+tie %!, __PACKAGE__;
+
+1;
+__END__
+
+=head1 NAME
+
+Errno - System errno constants
+
+=head1 SYNOPSIS
+
+ use Errno qw(EINTR EIO :POSIX);
+
+=head1 DESCRIPTION
+
+C<Errno> defines and conditionally exports all the error constants
+defined in your system C<errno.h> include file. It has a single export
+tag, C<:POSIX>, which will export all POSIX defined error numbers.
+
+C<Errno> also makes C<%!> magic such that each element of C<%!> has a
+non-zero value only if C<$!> is set to that value. For example:
+
+ use Errno;
+
+ unless (open(FH, "/fangorn/spouse")) {
+ if ($!{ENOENT}) {
+ warn "Get a wife!\n";
+ } else {
+ warn "This path is barred: $!";
+ }
+ }
+
+If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
+returns C<"">. You may use C<exists $!{EFOO}> to check whether the
+constant is available on the system.
+
+=head1 CAVEATS
+
+Importing a particular constant may not be very portable, because the
+import will fail on platforms that do not have that constant. A more
+portable way to set C<$!> to a valid value is to use:
+
+ if (exists &Errno::EFOO) {
+ $! = &Errno::EFOO;
+ }
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 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/Exporter.pm b/Master/tlpkg/tlperl/lib/Exporter.pm
new file mode 100644
index 00000000000..cd51828847e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Exporter.pm
@@ -0,0 +1,584 @@
+package Exporter;
+
+require 5.006;
+
+# Be lean.
+#use strict;
+#no strict 'refs';
+
+our $Debug = 0;
+our $ExportLevel = 0;
+our $Verbose ||= 0;
+our $VERSION = '5.64_01';
+our (%Cache);
+
+sub as_heavy {
+ require Exporter::Heavy;
+ # Unfortunately, this does not work if the caller is aliased as *name = \&foo
+ # Thus the need to create a lot of identical subroutines
+ my $c = (caller(1))[3];
+ $c =~ s/.*:://;
+ \&{"Exporter::Heavy::heavy_$c"};
+}
+
+sub export {
+ goto &{as_heavy()};
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller($ExportLevel);
+
+ if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
+ *{$callpkg."::import"} = \&import;
+ return;
+ }
+
+ # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
+ my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
+ return export $pkg, $callpkg, @_
+ if $Verbose or $Debug or @$fail > 1;
+ my $export_cache = ($Cache{$pkg} ||= {});
+ my $args = @_ or @_ = @$exports;
+
+ local $_;
+ if ($args and not %$export_cache) {
+ s/^&//, $export_cache->{$_} = 1
+ foreach (@$exports, @{"$pkg\::EXPORT_OK"});
+ }
+ my $heavy;
+ # Try very hard not to use {} and hence have to enter scope on the foreach
+ # We bomb out of the loop with last as soon as heavy is set.
+ if ($args or $fail) {
+ ($heavy = (/\W/ or $args and not exists $export_cache->{$_}
+ or @$fail and $_ eq $fail->[0])) and last
+ foreach (@_);
+ } else {
+ ($heavy = /\W/) and last
+ foreach (@_);
+ }
+ return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
+ local $SIG{__WARN__} =
+ sub {require Carp; &Carp::carp};
+ # shortcut for the common case of no type character
+ *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
+}
+
+# Default methods
+
+sub export_fail {
+ my $self = shift;
+ @_;
+}
+
+# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
+# *name = \&foo. Thus the need to create a lot of identical subroutines
+# Otherwise we could have aliased them to export().
+
+sub export_to_level {
+ goto &{as_heavy()};
+}
+
+sub export_tags {
+ goto &{as_heavy()};
+}
+
+sub export_ok_tags {
+ goto &{as_heavy()};
+}
+
+sub require_version {
+ goto &{as_heavy()};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Exporter - Implements default import method for modules
+
+=head1 SYNOPSIS
+
+In module F<YourModule.pm>:
+
+ package YourModule;
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
+
+or
+
+ package YourModule;
+ use Exporter 'import'; # gives you Exporter's import() method directly
+ @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
+
+In other files which wish to use C<YourModule>:
+
+ use YourModule qw(frobnicate); # import listed symbols
+ frobnicate ($left, $right) # calls YourModule::frobnicate
+
+Take a look at L</Good Practices> for some variants
+you will like to use in modern Perl code.
+
+=head1 DESCRIPTION
+
+The Exporter module implements an C<import> method which allows a module
+to export functions and variables to its users' namespaces. Many modules
+use Exporter rather than implementing their own C<import> method because
+Exporter provides a highly flexible interface, with an implementation optimised
+for the common case.
+
+Perl automatically calls the C<import> method when processing a
+C<use> statement for a module. Modules and C<use> are documented
+in L<perlfunc> and L<perlmod>. Understanding the concept of
+modules and how the C<use> statement operates is important to
+understanding the Exporter.
+
+=head2 How to Export
+
+The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
+symbols that are going to be exported into the users name space by
+default, or which they can request to be exported, respectively. The
+symbols can represent functions, scalars, arrays, hashes, or typeglobs.
+The symbols must be given by full name with the exception that the
+ampersand in front of a function is optional, e.g.
+
+ @EXPORT = qw(afunc $scalar @array); # afunc is a function
+ @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
+
+If you are only exporting function names it is recommended to omit the
+ampersand, as the implementation is faster this way.
+
+=head2 Selecting What To Export
+
+Do B<not> export method names!
+
+Do B<not> export anything else by default without a good reason!
+
+Exports pollute the namespace of the module user. If you must export
+try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
+common symbol names to reduce the risk of name clashes.
+
+Generally anything not exported is still accessible from outside the
+module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
+syntax. By convention you can use a leading underscore on names to
+informally indicate that they are 'internal' and not for public use.
+
+(It is actually possible to get private functions by saying:
+
+ my $subref = sub { ... };
+ $subref->(@args); # Call it as a function
+ $obj->$subref(@args); # Use it as a method
+
+However if you use them for methods it is up to you to figure out
+how to make inheritance work.)
+
+As a general rule, if the module is trying to be object oriented
+then export nothing. If it's just a collection of functions then
+C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
+method names use barewords in preference to names prefixed with
+ampersands for the export lists.
+
+Other module design guidelines can be found in L<perlmod>.
+
+=head2 How to Import
+
+In other files which wish to use your module there are three basic ways for
+them to load your module and import its symbols:
+
+=over 4
+
+=item C<use YourModule;>
+
+This imports all the symbols from YourModule's C<@EXPORT> into the namespace
+of the C<use> statement.
+
+=item C<use YourModule ();>
+
+This causes perl to load your module but does not import any symbols.
+
+=item C<use YourModule qw(...);>
+
+This imports only the symbols listed by the caller into their namespace.
+All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
+occurs. The advanced export features of Exporter are accessed like this,
+but with list entries that are syntactically distinct from symbol names.
+
+=back
+
+Unless you want to use its advanced features, this is probably all you
+need to know to use Exporter.
+
+=head1 Advanced features
+
+=head2 Specialised Import Lists
+
+If any of the entries in an import list begins with !, : or / then
+the list is treated as a series of specifications which either add to
+or delete from the list of names to import. They are processed left to
+right. Specifications are in the form:
+
+ [!]name This name only
+ [!]:DEFAULT All names in @EXPORT
+ [!]:tag All names in $EXPORT_TAGS{tag} anonymous list
+ [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
+
+A leading ! indicates that matching names should be deleted from the
+list of names to import. If the first specification is a deletion it
+is treated as though preceded by :DEFAULT. If you just want to import
+extra names in addition to the default set you will still need to
+include :DEFAULT explicitly.
+
+e.g., F<Module.pm> defines:
+
+ @EXPORT = qw(A1 A2 A3 A4 A5);
+ @EXPORT_OK = qw(B1 B2 B3 B4 B5);
+ %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
+
+ Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+ Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
+An application using Module can say something like:
+
+ use Module qw(:DEFAULT :T2 !B3 A3);
+
+Other examples include:
+
+ use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
+ use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
+
+Remember that most patterns (using //) will need to be anchored
+with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
+
+You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
+specifications are being processed and what is actually being imported
+into modules.
+
+=head2 Exporting without using Exporter's import method
+
+Exporter has a special method, 'export_to_level' which is used in situations
+where you can't directly call Exporter's import method. The export_to_level
+method looks like:
+
+ MyPackage->export_to_level($where_to_export, $package, @what_to_export);
+
+where C<$where_to_export> is an integer telling how far up the calling stack
+to export your symbols, and C<@what_to_export> is an array telling what
+symbols *to* export (usually this is C<@_>). The C<$package> argument is
+currently unused.
+
+For example, suppose that you have a module, A, which already has an
+import function:
+
+ package A;
+
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw ($b);
+
+ sub import
+ {
+ $A::b = 1; # not a very useful import method
+ }
+
+and you want to Export symbol C<$A::b> back to the module that called
+package A. Since Exporter relies on the import method to work, via
+inheritance, as it stands Exporter::import() will never get called.
+Instead, say the following:
+
+ package A;
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw ($b);
+
+ sub import
+ {
+ $A::b = 1;
+ A->export_to_level(1, @_);
+ }
+
+This will export the symbols one level 'above' the current package - ie: to
+the program or module that used package A.
+
+Note: Be careful not to modify C<@_> at all before you call export_to_level
+- or people using your package will get very unexplained results!
+
+=head2 Exporting without inheriting from Exporter
+
+By including Exporter in your C<@ISA> you inherit an Exporter's import() method
+but you also inherit several other helper methods which you probably don't
+want. To avoid this you can do
+
+ package YourModule;
+ use Exporter qw( import );
+
+which will export Exporter's own import() method into YourModule.
+Everything will work as before but you won't need to include Exporter in
+C<@YourModule::ISA>.
+
+Note: This feature was introduced in version 5.57
+of Exporter, released with perl 5.8.3.
+
+=head2 Module Version Checking
+
+The Exporter module will convert an attempt to import a number from a
+module into a call to C<< $module_name->require_version($value) >>. This can
+be used to validate that the version of the module being used is
+greater than or equal to the required version.
+
+The Exporter module supplies a default C<require_version> method which
+checks the value of C<$VERSION> in the exporting module.
+
+Since the default C<require_version> method treats the C<$VERSION> number as
+a simple numeric value it will regard version 1.10 as lower than
+1.9. For this reason it is strongly recommended that you use numbers
+with at least two decimal places, e.g., 1.09.
+
+=head2 Managing Unknown Symbols
+
+In some situations you may want to prevent certain symbols from being
+exported. Typically this applies to extensions which have functions
+or constants that may not exist on some systems.
+
+The names of any symbols that cannot be exported should be listed
+in the C<@EXPORT_FAIL> array.
+
+If a module attempts to import any of these symbols the Exporter
+will give the module an opportunity to handle the situation before
+generating an error. The Exporter will call an export_fail method
+with a list of the failed symbols:
+
+ @failed_symbols = $module_name->export_fail(@failed_symbols);
+
+If the C<export_fail> method returns an empty list then no error is
+recorded and all the requested symbols are exported. If the returned
+list is not empty then an error is generated for each symbol and the
+export fails. The Exporter provides a default C<export_fail> method which
+simply returns the list unchanged.
+
+Uses for the C<export_fail> method include giving better error messages
+for some symbols and performing lazy architectural checks (put more
+symbols into C<@EXPORT_FAIL> by default and then take them out if someone
+actually tries to use them and an expensive check shows that they are
+usable on that platform).
+
+=head2 Tag Handling Utility Functions
+
+Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
+C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
+you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
+
+ %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
+
+ Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
+ Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
+
+Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
+unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
+names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
+may make this a fatal error.
+
+=head2 Generating combined tags
+
+If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
+useful to create the utility ":all" to simplify "use" statements.
+
+The simplest way to do this is:
+
+ %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
+
+ # add all the other ":class" tags to the ":all" class,
+ # deleting duplicates
+ {
+ my %seen;
+
+ push @{$EXPORT_TAGS{all}},
+ grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
+ }
+
+F<CGI.pm> creates an ":all" tag which contains some (but not really
+all) of its categories. That could be done with one small
+change:
+
+ # add some of the other ":class" tags to the ":all" class,
+ # deleting duplicates
+ {
+ my %seen;
+
+ push @{$EXPORT_TAGS{all}},
+ grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
+ foreach qw/html2 html3 netscape form cgi internal/;
+ }
+
+Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
+
+=head2 C<AUTOLOAD>ed Constants
+
+Many modules make use of C<AUTOLOAD>ing for constant subroutines to
+avoid having to compile and waste memory on rarely used values (see
+L<perlsub> for details on constant subroutines). Calls to such
+constant subroutines are not optimized away at compile time because
+they can't be checked at compile time for constancy.
+
+Even if a prototype is available at compile time, the body of the
+subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
+examine both the C<()> prototype and the body of a subroutine at
+compile time to detect that it can safely replace calls to that
+subroutine with the constant value.
+
+A workaround for this is to call the constants once in a C<BEGIN> block:
+
+ package My ;
+
+ use Socket ;
+
+ foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
+ BEGIN { SO_LINGER }
+ foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
+
+This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
+SO_LINGER is encountered later in C<My> package.
+
+If you are writing a package that C<AUTOLOAD>s, consider forcing
+an C<AUTOLOAD> for any constants explicitly imported by other packages
+or which are usually used when your package is C<use>d.
+
+=head1 Good Practices
+
+=head2 Declaring C<@EXPORT_OK> and Friends
+
+When using C<Exporter> with the standard C<strict> and C<warnings>
+pragmas, the C<our> keyword is needed to declare the package
+variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
+
+ our @ISA = qw(Exporter);
+ our @EXPORT_OK = qw(munge frobnicate);
+
+If backward compatibility for Perls under 5.6 is important,
+one must write instead a C<use vars> statement.
+
+ use vars qw(@ISA @EXPORT_OK);
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(munge frobnicate);
+
+=head2 Playing Safe
+
+There are some caveats with the use of runtime statements
+like C<require Exporter> and the assignment to package
+variables, which can very subtle for the unaware programmer.
+This may happen for instance with mutually recursive
+modules, which are affected by the time the relevant
+constructions are executed.
+
+The ideal (but a bit ugly) way to never have to think
+about that is to use C<BEGIN> blocks. So the first part
+of the L</SYNOPSIS> code could be rewritten as:
+
+ package YourModule;
+
+ use strict;
+ use warnings;
+
+ our (@ISA, @EXPORT_OK);
+ BEGIN {
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
+ }
+
+The C<BEGIN> will assure that the loading of F<Exporter.pm>
+and the assignments to C<@ISA> and C<@EXPORT_OK> happen
+immediately, leaving no room for something to get awry
+or just plain wrong.
+
+With respect to loading C<Exporter> and inheriting, there
+are alternatives with the use of modules like C<base> and C<parent>.
+
+ use base qw( Exporter );
+ # or
+ use parent qw( Exporter );
+
+Any of these statements are nice replacements for
+C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
+with the same compile-time effect. The basic difference
+is that C<base> code interacts with declared C<fields>
+while C<parent> is a streamlined version of the older
+C<base> code to just establish the IS-A relationship.
+
+For more details, see the documentation and code of
+L<base> and L<parent>.
+
+Another thorough remedy to that runtime vs.
+compile-time trap is to use L<Exporter::Easy>,
+which is a wrapper of Exporter that allows all
+boilerplate code at a single gulp in the
+use statement.
+
+ use Exporter::Easy (
+ OK => [ qw(munge frobnicate) ],
+ );
+ # @ISA setup is automatic
+ # all assignments happen at compile time
+
+=head2 What not to Export
+
+You have been warned already in L</Selecting What To Export>
+to not export:
+
+=over 4
+
+=item *
+
+method names (because you don't need to
+and that's likely to not do what you want),
+
+=item *
+
+anything by default (because you don't want to surprise your users...
+badly)
+
+=item *
+
+anything you don't need to (because less is more)
+
+=back
+
+There's one more item to add to this list. Do B<not>
+export variable names. Just because C<Exporter> lets you
+do that, it does not mean you should.
+
+ @EXPORT_OK = qw( $svar @avar %hvar ); # DON'T!
+
+Exporting variables is not a good idea. They can
+change under the hood, provoking horrible
+effects at-a-distance, that are too hard to track
+and to fix. Trust me: they are not worth it.
+
+To provide the capability to set/get class-wide
+settings, it is best instead to provide accessors
+as subroutines or class methods instead.
+
+=head1 SEE ALSO
+
+C<Exporter> is definitely not the only module with
+symbol exporter capabilities. At CPAN, you may find
+a bunch of them. Some are lighter. Some
+provide improved APIs and features. Peek the one
+that fits your needs. The following is
+a sample list of such modules.
+
+ Exporter::Easy
+ Exporter::Lite
+ Exporter::Renaming
+ Exporter::Tidy
+ Sub::Exporter / Sub::Installer
+ Perl6::Export / Perl6::Export::Attrs
+
+=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/Fatal.pm b/Master/tlpkg/tlperl/lib/Fatal.pm
new file mode 100644
index 00000000000..18e71ed21a3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Fatal.pm
@@ -0,0 +1,1374 @@
+package Fatal;
+
+use 5.008; # 5.8.x needed for autodie
+use Carp;
+use strict;
+use warnings;
+use Tie::RefHash; # To cache subroutine refs
+
+use constant PERL510 => ( $] >= 5.010 );
+
+use constant LEXICAL_TAG => q{:lexical};
+use constant VOID_TAG => q{:void};
+use constant INSIST_TAG => q{!};
+
+use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
+use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
+use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
+use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
+use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
+use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
+use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
+use constant ERROR_NOHINTS => "No user hints defined for %s";
+
+use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
+
+use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
+
+use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
+
+use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
+
+use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
+
+use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
+
+# Older versions of IPC::System::Simple don't support all the
+# features we need.
+
+use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
+
+# All the Fatal/autodie modules share the same version number.
+our $VERSION = '2.06_01';
+
+our $Debug ||= 0;
+
+# EWOULDBLOCK values for systems that don't supply their own.
+# Even though this is defined with our, that's to help our
+# test code. Please don't rely upon this variable existing in
+# the future.
+
+our %_EWOULDBLOCK = (
+ MSWin32 => 33,
+);
+
+# We have some tags that can be passed in for use with import.
+# These are all assumed to be CORE::
+
+my %TAGS = (
+ ':io' => [qw(:dbm :file :filesys :ipc :socket
+ read seek sysread syswrite sysseek )],
+ ':dbm' => [qw(dbmopen dbmclose)],
+ ':file' => [qw(open close flock sysopen fcntl fileno binmode
+ ioctl truncate)],
+ ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
+ symlink rmdir readlink umask)],
+ ':ipc' => [qw(:msg :semaphore :shm pipe)],
+ ':msg' => [qw(msgctl msgget msgrcv msgsnd)],
+ ':threads' => [qw(fork)],
+ ':semaphore'=>[qw(semctl semget semop)],
+ ':shm' => [qw(shmctl shmget shmread)],
+ ':system' => [qw(system exec)],
+
+ # Can we use qw(getpeername getsockname)? What do they do on failure?
+ # TODO - Can socket return false?
+ ':socket' => [qw(accept bind connect getsockopt listen recv send
+ setsockopt shutdown socketpair)],
+
+ # Our defaults don't include system(), because it depends upon
+ # an optional module, and it breaks the exotic form.
+ #
+ # This *may* change in the future. I'd love IPC::System::Simple
+ # to be a dependency rather than a recommendation, and hence for
+ # system() to be autodying by default.
+
+ ':default' => [qw(:io :threads)],
+
+ # Version specific tags. These allow someone to specify
+ # use autodie qw(:1.994) and know exactly what they'll get.
+
+ ':1.994' => [qw(:default)],
+ ':1.995' => [qw(:default)],
+ ':1.996' => [qw(:default)],
+ ':1.997' => [qw(:default)],
+ ':1.998' => [qw(:default)],
+ ':1.999' => [qw(:default)],
+ ':1.999_01' => [qw(:default)],
+ ':2.00' => [qw(:default)],
+ ':2.01' => [qw(:default)],
+ ':2.02' => [qw(:default)],
+ ':2.03' => [qw(:default)],
+ ':2.04' => [qw(:default)],
+ ':2.05' => [qw(:default)],
+ ':2.06' => [qw(:default)],
+ ':2.06_01' => [qw(:default)],
+);
+
+$TAGS{':all'} = [ keys %TAGS ];
+
+# This hash contains subroutines for which we should
+# subroutine() // die() rather than subroutine() || die()
+
+my %Use_defined_or;
+
+# CORE::open returns undef on failure. It can legitimately return
+# 0 on success, eg: open(my $fh, '-|') || exec(...);
+
+@Use_defined_or{qw(
+ CORE::fork
+ CORE::recv
+ CORE::send
+ CORE::open
+ CORE::fileno
+ CORE::read
+ CORE::readlink
+ CORE::sysread
+ CORE::syswrite
+ CORE::sysseek
+ CORE::umask
+)} = ();
+
+# Cached_fatalised_sub caches the various versions of our
+# fatalised subs as they're produced. This means we don't
+# have to build our own replacement of CORE::open and friends
+# for every single package that wants to use them.
+
+my %Cached_fatalised_sub = ();
+
+# Every time we're called with package scope, we record the subroutine
+# (including package or CORE::) in %Package_Fatal. This allows us
+# to detect illegal combinations of autodie and Fatal, and makes sure
+# we don't accidently make a Fatal function autodying (which isn't
+# very useful).
+
+my %Package_Fatal = ();
+
+# The first time we're called with a user-sub, we cache it here.
+# In the case of a "no autodie ..." we put back the cached copy.
+
+my %Original_user_sub = ();
+
+# Is_fatalised_sub simply records a big map of fatalised subroutine
+# refs. It means we can avoid repeating work, or fatalising something
+# we've already processed.
+
+my %Is_fatalised_sub = ();
+tie %Is_fatalised_sub, 'Tie::RefHash';
+
+# We use our package in a few hash-keys. Having it in a scalar is
+# convenient. The "guard $PACKAGE" string is used as a key when
+# setting up lexical guards.
+
+my $PACKAGE = __PACKAGE__;
+my $PACKAGE_GUARD = "guard $PACKAGE";
+my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
+
+# Here's where all the magic happens when someone write 'use Fatal'
+# or 'use autodie'.
+
+sub import {
+ my $class = shift(@_);
+ my $void = 0;
+ my $lexical = 0;
+ my $insist_hints = 0;
+
+ my ($pkg, $filename) = caller();
+
+ @_ or return; # 'use Fatal' is a no-op.
+
+ # If we see the :lexical flag, then _all_ arguments are
+ # changed lexically
+
+ if ($_[0] eq LEXICAL_TAG) {
+ $lexical = 1;
+ shift @_;
+
+ # If we see no arguments and :lexical, we assume they
+ # wanted ':default'.
+
+ if (@_ == 0) {
+ push(@_, ':default');
+ }
+
+ # Don't allow :lexical with :void, it's needlessly confusing.
+ if ( grep { $_ eq VOID_TAG } @_ ) {
+ croak(ERROR_VOID_LEX);
+ }
+ }
+
+ if ( grep { $_ eq LEXICAL_TAG } @_ ) {
+ # If we see the lexical tag as the non-first argument, complain.
+ croak(ERROR_LEX_FIRST);
+ }
+
+ my @fatalise_these = @_;
+
+ # Thiese subs will get unloaded at the end of lexical scope.
+ my %unload_later;
+
+ # This hash helps us track if we've alredy done work.
+ my %done_this;
+
+ # NB: we're using while/shift rather than foreach, since
+ # we'll be modifying the array as we walk through it.
+
+ while (my $func = shift @fatalise_these) {
+
+ if ($func eq VOID_TAG) {
+
+ # When we see :void, set the void flag.
+ $void = 1;
+
+ } elsif ($func eq INSIST_TAG) {
+
+ $insist_hints = 1;
+
+ } elsif (exists $TAGS{$func}) {
+
+ # When it's a tag, expand it.
+ push(@fatalise_these, @{ $TAGS{$func} });
+
+ } else {
+
+ # Otherwise, fatalise it.
+
+ # Check to see if there's an insist flag at the front.
+ # If so, remove it, and insist we have hints for this sub.
+ my $insist_this;
+
+ if ($func =~ s/^!//) {
+ $insist_this = 1;
+ }
+
+ # TODO: Even if we've already fatalised, we should
+ # check we've done it with hints (if $insist_hints).
+
+ # If we've already made something fatal this call,
+ # then don't do it twice.
+
+ next if $done_this{$func};
+
+ # We're going to make a subroutine fatalistic.
+ # However if we're being invoked with 'use Fatal qw(x)'
+ # and we've already been called with 'no autodie qw(x)'
+ # in the same scope, we consider this to be an error.
+ # Mixing Fatal and autodie effects was considered to be
+ # needlessly confusing on p5p.
+
+ my $sub = $func;
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # If we're being called as Fatal, and we've previously
+ # had a 'no X' in scope for the subroutine, then complain
+ # bitterly.
+
+ if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
+ croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
+ }
+
+ # We're not being used in a confusing way, so make
+ # the sub fatal. Note that _make_fatal returns the
+ # old (original) version of the sub, or undef for
+ # built-ins.
+
+ my $sub_ref = $class->_make_fatal(
+ $func, $pkg, $void, $lexical, $filename,
+ ( $insist_this || $insist_hints )
+ );
+
+ $done_this{$func}++;
+
+ $Original_user_sub{$sub} ||= $sub_ref;
+
+ # If we're making lexical changes, we need to arrange
+ # for them to be cleaned at the end of our scope, so
+ # record them here.
+
+ $unload_later{$func} = $sub_ref if $lexical;
+ }
+ }
+
+ if ($lexical) {
+
+ # Dark magic to have autodie work under 5.8
+ # Copied from namespace::clean, that copied it from
+ # autobox, that found it on an ancient scroll written
+ # in blood.
+
+ # This magic bit causes %^H to be lexically scoped.
+
+ $^H |= 0x020000;
+
+ # Our package guard gets invoked when we leave our lexical
+ # scope.
+
+ push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
+ $class->_install_subs($pkg, \%unload_later);
+ }));
+
+ }
+
+ return;
+
+}
+
+# The code here is originally lifted from namespace::clean,
+# by Robert "phaylon" Sedlacek.
+#
+# It's been redesigned after feedback from ikegami on perlmonks.
+# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
+#
+# Given a package, and hash of (subname => subref) pairs,
+# we install the given subroutines into the package. If
+# a subref is undef, the subroutine is removed. Otherwise
+# it replaces any existing subs which were already there.
+
+sub _install_subs {
+ my ($class, $pkg, $subs_to_reinstate) = @_;
+
+ my $pkg_sym = "${pkg}::";
+
+ while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
+
+ my $full_path = $pkg_sym.$sub_name;
+
+ # Copy symbols across to temp area.
+
+ no strict 'refs'; ## no critic
+
+ local *__tmp = *{ $full_path };
+
+ # Nuke the old glob.
+ { no strict; delete $pkg_sym->{$sub_name}; } ## no critic
+
+ # Copy innocent bystanders back. Note that we lose
+ # formats; it seems that Perl versions up to 5.10.0
+ # have a bug which causes copying formats to end up in
+ # the scalar slot. Thanks to Ben Morrow for spotting this.
+
+ foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
+ next unless defined *__tmp{ $slot };
+ *{ $full_path } = *__tmp{ $slot };
+ }
+
+ # Put back the old sub (if there was one).
+
+ if ($sub_ref) {
+
+ no strict; ## no critic
+ *{ $pkg_sym . $sub_name } = $sub_ref;
+ }
+ }
+
+ return;
+}
+
+sub unimport {
+ my $class = shift;
+
+ # Calling "no Fatal" must start with ":lexical"
+ if ($_[0] ne LEXICAL_TAG) {
+ croak(sprintf(ERROR_NO_LEX,$class));
+ }
+
+ shift @_; # Remove :lexical
+
+ my $pkg = (caller)[0];
+
+ # If we've been called with arguments, then the developer
+ # has explicitly stated 'no autodie qw(blah)',
+ # in which case, we disable Fatalistic behaviour for 'blah'.
+
+ my @unimport_these = @_ ? @_ : ':all';
+
+ while (my $symbol = shift @unimport_these) {
+
+ if ($symbol =~ /^:/) {
+
+ # Looks like a tag! Expand it!
+ push(@unimport_these, @{ $TAGS{$symbol} });
+
+ next;
+ }
+
+ my $sub = $symbol;
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # If 'blah' was already enabled with Fatal (which has package
+ # scope) then, this is considered an error.
+
+ if (exists $Package_Fatal{$sub}) {
+ croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
+ }
+
+ # Record 'no autodie qw($sub)' as being in effect.
+ # This is to catch conflicting semantics elsewhere
+ # (eg, mixing Fatal with no autodie)
+
+ $^H{$NO_PACKAGE}{$sub} = 1;
+
+ if (my $original_sub = $Original_user_sub{$sub}) {
+ # Hey, we've got an original one of these, put it back.
+ $class->_install_subs($pkg, { $symbol => $original_sub });
+ next;
+ }
+
+ # We don't have an original copy of the sub, on the assumption
+ # it's core (or doesn't exist), we'll just nuke it.
+
+ $class->_install_subs($pkg,{ $symbol => undef });
+
+ }
+
+ return;
+
+}
+
+# TODO - This is rather terribly inefficient right now.
+
+# NB: Perl::Critic's dump-autodie-tag-contents depends upon this
+# continuing to work.
+
+{
+ my %tag_cache;
+
+ sub _expand_tag {
+ my ($class, $tag) = @_;
+
+ if (my $cached = $tag_cache{$tag}) {
+ return $cached;
+ }
+
+ if (not exists $TAGS{$tag}) {
+ croak "Invalid exception class $tag";
+ }
+
+ my @to_process = @{$TAGS{$tag}};
+
+ my @taglist = ();
+
+ while (my $item = shift @to_process) {
+ if ($item =~ /^:/) {
+ push(@to_process, @{$TAGS{$item}} );
+ } else {
+ push(@taglist, "CORE::$item");
+ }
+ }
+
+ $tag_cache{$tag} = \@taglist;
+
+ return \@taglist;
+
+ }
+
+}
+
+# This code is from the original Fatal. It scares me.
+# It is 100% compatible with the 5.10.0 Fatal module, right down
+# to the scary 'XXXX' comment. ;)
+
+sub fill_protos {
+ my $proto = shift;
+ my ($n, $isref, @out, @out1, $seen_semi) = -1;
+ while ($proto =~ /\S/) {
+ $n++;
+ push(@out1,[$n,@out]) if $seen_semi;
+ push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
+ push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
+ push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
+ $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
+ die "Internal error: Unknown prototype letters: \"$proto\"";
+ }
+ push(@out1,[$n+1,@out]);
+ return @out1;
+}
+
+# This is a backwards compatible version of _write_invocation. It's
+# recommended you don't use it.
+
+sub write_invocation {
+ my ($core, $call, $name, $void, @args) = @_;
+
+ return Fatal->_write_invocation(
+ $core, $call, $name, $void,
+ 0, # Lexical flag
+ undef, # Sub, unused in legacy mode
+ undef, # Subref, unused in legacy mode.
+ @args
+ );
+}
+
+# This version of _write_invocation is used internally. It's not
+# recommended you call it from external code, as the interface WILL
+# change in the future.
+
+sub _write_invocation {
+
+ my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
+
+ if (@argvs == 1) { # No optional arguments
+
+ my @argv = @{$argvs[0]};
+ shift @argv;
+
+ return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
+
+ } else {
+ my $else = "\t";
+ my (@out, @argv, $n);
+ while (@argvs) {
+ @argv = @{shift @argvs};
+ $n = shift @argv;
+
+ push @out, "${else}if (\@_ == $n) {\n";
+ $else = "\t} els";
+
+ push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
+ }
+ push @out, qq[
+ }
+ die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
+ ];
+
+ return join '', @out;
+ }
+}
+
+
+# This is a slim interface to ensure backward compatibility with
+# anyone doing very foolish things with old versions of Fatal.
+
+sub one_invocation {
+ my ($core, $call, $name, $void, @argv) = @_;
+
+ return Fatal->_one_invocation(
+ $core, $call, $name, $void,
+ undef, # Sub. Unused in back-compat mode.
+ 1, # Back-compat flag
+ undef, # Subref, unused in back-compat mode.
+ @argv
+ );
+
+}
+
+# This is the internal interface that generates code.
+# NOTE: This interface WILL change in the future. Please do not
+# call this subroutine directly.
+
+# TODO: Whatever's calling this code has already looked up hints. Pass
+# them in, rather than look them up a second time.
+
+sub _one_invocation {
+ my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
+
+
+ # If someone is calling us directly (a child class perhaps?) then
+ # they could try to mix void without enabling backwards
+ # compatibility. We just don't support this at all, so we gripe
+ # about it rather than doing something unwise.
+
+ if ($void and not $back_compat) {
+ Carp::confess("Internal error: :void mode not supported with $class");
+ }
+
+ # @argv only contains the results of the in-built prototype
+ # function, and is therefore safe to interpolate in the
+ # code generators below.
+
+ # TODO - The following clobbers context, but that's what the
+ # old Fatal did. Do we care?
+
+ if ($back_compat) {
+
+ # Use Fatal qw(system) will never be supported. It generated
+ # a compile-time error with legacy Fatal, and there's no reason
+ # to support it when autodie does a better job.
+
+ if ($call eq 'CORE::system') {
+ return q{
+ croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
+ };
+ }
+
+ local $" = ', ';
+
+ if ($void) {
+ return qq/return (defined wantarray)?$call(@argv):
+ $call(@argv) || croak "Can't $name(\@_)/ .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"'
+ } else {
+ return qq{return $call(@argv) || croak "Can't $name(\@_)} .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+ }
+ }
+
+ # The name of our original function is:
+ # $call if the function is CORE
+ # $sub if our function is non-CORE
+
+ # The reason for this is that $call is what we're actualling
+ # calling. For our core functions, this is always
+ # CORE::something. However for user-defined subs, we're about to
+ # replace whatever it is that we're calling; as such, we actually
+ # calling a subroutine ref.
+
+ my $human_sub_name = $core ? $call : $sub;
+
+ # Should we be testing to see if our result is defined, or
+ # just true?
+
+ my $use_defined_or;
+
+ my $hints; # All user-sub hints, including list hints.
+
+ if ( $core ) {
+
+ # Core hints are built into autodie.
+
+ $use_defined_or = exists ( $Use_defined_or{$call} );
+
+ }
+ else {
+
+ # User sub hints are looked up using autodie::hints,
+ # since users may wish to add their own hints.
+
+ require autodie::hints;
+
+ $hints = autodie::hints->get_hints_for( $sref );
+
+ # We'll look up the sub's fullname. This means we
+ # get better reports of where it came from in our
+ # error messages, rather than what imported it.
+
+ $human_sub_name = autodie::hints->sub_fullname( $sref );
+
+ }
+
+ # Checks for special core subs.
+
+ if ($call eq 'CORE::system') {
+
+ # Leverage IPC::System::Simple if we're making an autodying
+ # system.
+
+ local $" = ", ";
+
+ # We need to stash $@ into $E, rather than using
+ # local $@ for the whole sub. If we don't then
+ # any exceptions from internal errors in autodie/Fatal
+ # will mysteriously disappear before propogating
+ # upwards.
+
+ return qq{
+ my \$retval;
+ my \$E;
+
+
+ {
+ local \$@;
+
+ eval {
+ \$retval = IPC::System::Simple::system(@argv);
+ };
+
+ \$E = \$@;
+ }
+
+ if (\$E) {
+
+ # TODO - This can't be overridden in child
+ # classes!
+
+ die autodie::exception::system->new(
+ function => q{CORE::system}, args => [ @argv ],
+ message => "\$E", errno => \$!,
+ );
+ }
+
+ return \$retval;
+ };
+
+ }
+
+ local $" = ', ';
+
+ # If we're going to throw an exception, here's the code to use.
+ my $die = qq{
+ die $class->throw(
+ function => q{$human_sub_name}, args => [ @argv ],
+ pragma => q{$class}, errno => \$!,
+ context => \$context, return => \$retval,
+ eval_error => \$@
+ )
+ };
+
+ if ($call eq 'CORE::flock') {
+
+ # flock needs special treatment. When it fails with
+ # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
+ # means we couldn't get the lock right now.
+
+ require POSIX; # For POSIX::EWOULDBLOCK
+
+ local $@; # Don't blat anyone else's $@.
+
+ # Ensure that our vendor supports EWOULDBLOCK. If they
+ # don't (eg, Windows), then we use known values for its
+ # equivalent on other systems.
+
+ my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
+ || $_EWOULDBLOCK{$^O}
+ || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
+
+ require Fcntl; # For Fcntl::LOCK_NB
+
+ return qq{
+
+ my \$context = wantarray() ? "list" : "scalar";
+
+ # Try to flock. If successful, return it immediately.
+
+ my \$retval = $call(@argv);
+ return \$retval if \$retval;
+
+ # If we failed, but we're using LOCK_NB and
+ # returned EWOULDBLOCK, it's not a real error.
+
+ if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) {
+ return \$retval;
+ }
+
+ # Otherwise, we failed. Die noisily.
+
+ $die;
+
+ };
+ }
+
+ # AFAIK everything that can be given an unopned filehandle
+ # will fail if it tries to use it, so we don't really need
+ # the 'unopened' warning class here. Especially since they
+ # then report the wrong line number.
+
+ # Other warnings are disabled because they produce excessive
+ # complaints from smart-match hints under 5.10.1.
+
+ my $code = qq[
+ no warnings qw(unopened uninitialized numeric);
+
+ if (wantarray) {
+ my \@results = $call(@argv);
+ my \$retval = \\\@results;
+ my \$context = "list";
+
+ ];
+
+ if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
+
+ # NB: Subroutine hints are passed as a full list.
+ # This differs from the 5.10.0 smart-match behaviour,
+ # but means that context unaware subroutines can use
+ # the same hints in both list and scalar context.
+
+ $code .= qq{
+ if ( \$hints->{list}->(\@results) ) { $die };
+ };
+ }
+ elsif ( PERL510 and $hints ) {
+ $code .= qq{
+ if ( \@results ~~ \$hints->{list} ) { $die };
+ };
+ }
+ elsif ( $hints ) {
+ croak sprintf(ERROR_58_HINTS, 'list', $sub);
+ }
+ else {
+ $code .= qq{
+ # An empty list, or a single undef is failure
+ if (! \@results or (\@results == 1 and ! defined \$results[0])) {
+ $die;
+ }
+ }
+ }
+
+ # Tidy up the end of our wantarray call.
+
+ $code .= qq[
+ return \@results;
+ }
+ ];
+
+
+ # Otherwise, we're in scalar context.
+ # We're never in a void context, since we have to look
+ # at the result.
+
+ $code .= qq{
+ my \$retval = $call(@argv);
+ my \$context = "scalar";
+ };
+
+ if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
+
+ # We always call code refs directly, since that always
+ # works in 5.8.x, and always works in 5.10.1
+
+ return $code .= qq{
+ if ( \$hints->{scalar}->(\$retval) ) { $die };
+ return \$retval;
+ };
+
+ }
+ elsif (PERL510 and $hints) {
+ return $code . qq{
+
+ if ( \$retval ~~ \$hints->{scalar} ) { $die };
+
+ return \$retval;
+ };
+ }
+ elsif ( $hints ) {
+ croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
+ }
+
+ return $code .
+ ( $use_defined_or ? qq{
+
+ $die if not defined \$retval;
+
+ return \$retval;
+
+ } : qq{
+
+ return \$retval || $die;
+
+ } ) ;
+
+}
+
+# This returns the old copy of the sub, so we can
+# put it back at end of scope.
+
+# TODO : Check to make sure prototypes are restored correctly.
+
+# TODO: Taking a huge list of arguments is awful. Rewriting to
+# take a hash would be lovely.
+
+# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
+
+sub _make_fatal {
+ my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
+ my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
+ my $ini = $sub;
+
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # Figure if we're using lexical or package semantics and
+ # twiddle the appropriate bits.
+
+ if (not $lexical) {
+ $Package_Fatal{$sub} = 1;
+ }
+
+ # TODO - We *should* be able to do skipping, since we know when
+ # we've lexicalised / unlexicalised a subroutine.
+
+ $name = $sub;
+ $name =~ s/.*::// or $name =~ s/^&//;
+
+ warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
+ croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
+
+ if (defined(&$sub)) { # user subroutine
+
+ # NOTE: Previously we would localise $@ at this point, so
+ # the following calls to eval {} wouldn't interfere with anything
+ # that's already in $@. Unfortunately, it would also stop
+ # any of our croaks from triggering(!), which is even worse.
+
+ # This could be something that we've fatalised that
+ # was in core.
+
+ if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
+
+ # Something we previously made Fatal that was core.
+ # This is safe to replace with an autodying to core
+ # version.
+
+ $core = 1;
+ $call = "CORE::$name";
+ $proto = prototype $call;
+
+ # We return our $sref from this subroutine later
+ # on, indicating this subroutine should be placed
+ # back when we're finished.
+
+ $sref = \&$sub;
+
+ } else {
+
+ # If this is something we've already fatalised or played with,
+ # then look-up the name of the original sub for the rest of
+ # our processing.
+
+ $sub = $Is_fatalised_sub{\&$sub} || $sub;
+
+ # A regular user sub, or a user sub wrapping a
+ # core sub.
+
+ $sref = \&$sub;
+ $proto = prototype $sref;
+ $call = '&$sref';
+ require autodie::hints;
+
+ $hints = autodie::hints->get_hints_for( $sref );
+
+ # If we've insisted on hints, but don't have them, then
+ # bail out!
+
+ if ($insist and not $hints) {
+ croak(sprintf(ERROR_NOHINTS, $name));
+ }
+
+ # Otherwise, use the default hints if we don't have
+ # any.
+
+ $hints ||= autodie::hints::DEFAULT_HINTS();
+
+ }
+
+ } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
+ # Stray user subroutine
+ croak(sprintf(ERROR_NOTSUB,$sub));
+
+ } elsif ($name eq 'system') {
+
+ # If we're fatalising system, then we need to load
+ # helper code.
+
+ # The business with $E is to avoid clobbering our caller's
+ # $@, and to avoid $@ being localised when we croak.
+
+ my $E;
+
+ {
+ local $@;
+
+ eval {
+ require IPC::System::Simple; # Only load it if we need it.
+ require autodie::exception::system;
+ };
+ $E = $@;
+ }
+
+ if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
+
+ # Make sure we're using a recent version of ISS that actually
+ # support fatalised system.
+ if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
+ croak sprintf(
+ ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
+ $IPC::System::Simple::VERSION
+ );
+ }
+
+ $call = 'CORE::system';
+ $name = 'system';
+ $core = 1;
+
+ } elsif ($name eq 'exec') {
+ # Exec doesn't have a prototype. We don't care. This
+ # breaks the exotic form with lexical scope, and gives
+ # the regular form a "do or die" beaviour as expected.
+
+ $call = 'CORE::exec';
+ $name = 'exec';
+ $core = 1;
+
+ } else { # CORE subroutine
+ my $E;
+ {
+ local $@;
+ $proto = eval { prototype "CORE::$name" };
+ $E = $@;
+ }
+ croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
+ croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
+ $core = 1;
+ $call = "CORE::$name";
+ }
+
+ if (defined $proto) {
+ $real_proto = " ($proto)";
+ } else {
+ $real_proto = '';
+ $proto = '@';
+ }
+
+ my $true_name = $core ? $call : $sub;
+
+ # TODO: This caching works, but I don't like using $void and
+ # $lexical as keys. In particular, I suspect our code may end up
+ # wrapping already wrapped code when autodie and Fatal are used
+ # together.
+
+ # NB: We must use '$sub' (the name plus package) and not
+ # just '$name' (the short name) here. Failing to do so
+ # results code that's in the wrong package, and hence has
+ # access to the wrong package filehandles.
+
+ if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
+ $class->_install_subs($pkg, { $name => $subref });
+ return $sref;
+ }
+
+ $code = qq[
+ sub$real_proto {
+ local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
+ ];
+
+ # Don't have perl whine if exec fails, since we'll be handling
+ # the exception now.
+ $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
+
+ my @protos = fill_protos($proto);
+ $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
+ $code .= "}\n";
+ warn $code if $Debug;
+
+ # I thought that changing package was a monumental waste of
+ # time for CORE subs, since they'll always be the same. However
+ # that's not the case, since they may refer to package-based
+ # filehandles (eg, with open).
+ #
+ # There is potential to more aggressively cache core subs
+ # that we know will never want to interact with package variables
+ # and filehandles.
+
+ {
+ no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
+
+ my $E;
+
+ {
+ local $@;
+ $code = eval("package $pkg; use Carp; $code"); ## no critic
+ $E = $@;
+ }
+
+ if (not $code) {
+ croak("Internal error in autodie/Fatal processing $true_name: $E");
+
+ }
+ }
+
+ # Now we need to wrap our fatalised sub inside an itty bitty
+ # closure, which can detect if we've leaked into another file.
+ # Luckily, we only need to do this for lexical (autodie)
+ # subs. Fatal subs can leak all they want, it's considered
+ # a "feature" (or at least backwards compatible).
+
+ # TODO: Cache our leak guards!
+
+ # TODO: This is pretty hairy code. A lot more tests would
+ # be really nice for this.
+
+ my $leak_guard;
+
+ if ($lexical) {
+
+ $leak_guard = qq<
+ package $pkg;
+
+ sub$real_proto {
+
+ # If we're inside a string eval, we can end up with a
+ # whacky filename. The following code allows autodie
+ # to propagate correctly into string evals.
+
+ my \$caller_level = 0;
+
+ my \$caller;
+
+ while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
+
+ # If our filename is actually an eval, and we
+ # reach it, then go to our autodying code immediatately.
+
+ goto &\$code if (\$caller eq \$filename);
+ \$caller_level++;
+ }
+
+ # We're now out of the eval stack.
+
+ # If we're called from the correct file, then use the
+ # autodying code.
+ goto &\$code if ((caller \$caller_level)[1] eq \$filename);
+
+ # Oh bother, we've leaked into another file. Call the
+ # original code. Note that \$sref may actually be a
+ # reference to a Fatalised version of a core built-in.
+ # That's okay, because Fatal *always* leaks between files.
+
+ goto &\$sref if \$sref;
+ >;
+
+
+ # If we're here, it must have been a core subroutine called.
+ # Warning: The following code may disturb some viewers.
+
+ # TODO: It should be possible to combine this with
+ # write_invocation().
+
+ foreach my $proto (@protos) {
+ local $" = ", "; # So @args is formatted correctly.
+ my ($count, @args) = @$proto;
+ $leak_guard .= qq<
+ if (\@_ == $count) {
+ return $call(@args);
+ }
+ >;
+ }
+
+ $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >;
+
+ # warn "$leak_guard\n";
+
+ my $E;
+ {
+ local $@;
+
+ $leak_guard = eval $leak_guard; ## no critic
+
+ $E = $@;
+ }
+
+ die "Internal error in $class: Leak-guard installation failure: $E" if $E;
+ }
+
+ my $installed_sub = $leak_guard || $code;
+
+ $class->_install_subs($pkg, { $name => $installed_sub });
+
+ $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
+
+ # Cache that we've now overriddent this sub. If we get called
+ # again, we may need to find that find subroutine again (eg, for hints).
+
+ $Is_fatalised_sub{$installed_sub} = $sref;
+
+ return $sref;
+
+}
+
+# This subroutine exists primarily so that child classes can override
+# it to point to their own exception class. Doing this is significantly
+# less complex than overriding throw()
+
+sub exception_class { return "autodie::exception" };
+
+{
+ my %exception_class_for;
+ my %class_loaded;
+
+ sub throw {
+ my ($class, @args) = @_;
+
+ # Find our exception class if we need it.
+ my $exception_class =
+ $exception_class_for{$class} ||= $class->exception_class;
+
+ if (not $class_loaded{$exception_class}) {
+ if ($exception_class =~ /[^\w:']/) {
+ confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
+ }
+
+ # Alas, Perl does turn barewords into modules unless they're
+ # actually barewords. As such, we're left doing a string eval
+ # to make sure we load our file correctly.
+
+ my $E;
+
+ {
+ local $@; # We can't clobber $@, it's wrong!
+ eval "require $exception_class"; ## no critic
+ $E = $@; # Save $E despite ending our local.
+ }
+
+ # We need quotes around $@ to make sure it's stringified
+ # while still in scope. Without them, we run the risk of
+ # $@ having been cleared by us exiting the local() block.
+
+ confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
+
+ $class_loaded{$exception_class}++;
+
+ }
+
+ return $exception_class->new(@args);
+ }
+}
+
+# For some reason, dying while replacing our subs doesn't
+# kill our calling program. It simply stops the loading of
+# autodie and keeps going with everything else. The _autocroak
+# sub allows us to die with a vegence. It should *only* ever be
+# used for serious internal errors, since the results of it can't
+# be captured.
+
+sub _autocroak {
+ warn Carp::longmess(@_);
+ exit(255); # Ugh!
+}
+
+package autodie::Scope::Guard;
+
+# This code schedules the cleanup of subroutines at the end of
+# scope. It's directly inspired by chocolateboy's excellent
+# Scope::Guard module.
+
+sub new {
+ my ($class, $handler) = @_;
+
+ return bless $handler, $class;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Fatal - Replace functions with equivalents which succeed or die
+
+=head1 SYNOPSIS
+
+ use Fatal qw(open close);
+
+ open(my $fh, "<", $filename); # No need to check errors!
+
+ use File::Copy qw(move);
+ use Fatal qw(move);
+
+ move($file1, $file2); # No need to check errors!
+
+ sub juggle { . . . }
+ Fatal->import('juggle');
+
+=head1 BEST PRACTICE
+
+B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
+L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
+throws real exception objects, and provides much nicer error messages.
+
+The use of C<:void> with Fatal is discouraged.
+
+=head1 DESCRIPTION
+
+C<Fatal> provides a way to conveniently replace
+functions which normally return a false value when they fail with
+equivalents which raise exceptions if they are not successful. This
+lets you use these functions without having to test their return
+values explicitly on each call. Exceptions can be caught using
+C<eval{}>. See L<perlfunc> and L<perlvar> for details.
+
+The do-or-die equivalents are set up simply by calling Fatal's
+C<import> routine, passing it the names of the functions to be
+replaced. You may wrap both user-defined functions and overridable
+CORE operators (except C<exec>, C<system>, C<print>, or any other
+built-in that cannot be expressed via prototypes) in this way.
+
+If the symbol C<:void> appears in the import list, then functions
+named later in that import list raise an exception only when
+these are called in void context--that is, when their return
+values are ignored. For example
+
+ use Fatal qw/:void open close/;
+
+ # properly checked, so no exception raised on error
+ if (not open(my $fh, '<', '/bogotic') {
+ warn "Can't open /bogotic: $!";
+ }
+
+ # not checked, so error raises an exception
+ close FH;
+
+The use of C<:void> is discouraged, as it can result in exceptions
+not being thrown if you I<accidentally> call a method without
+void context. Use L<autodie> instead if you need to be able to
+disable autodying/Fatal behaviour for a small block of code.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Bad subroutine name for Fatal: %s
+
+You've called C<Fatal> with an argument that doesn't look like
+a subroutine name, nor a switch that this version of Fatal
+understands.
+
+=item %s is not a Perl subroutine
+
+You've asked C<Fatal> to try and replace a subroutine which does not
+exist, or has not yet been defined.
+
+=item %s is neither a builtin, nor a Perl subroutine
+
+You've asked C<Fatal> to replace a subroutine, but it's not a Perl
+built-in, and C<Fatal> couldn't find it as a regular subroutine.
+It either doesn't exist or has not yet been defined.
+
+=item Cannot make the non-overridable %s fatal
+
+You've tried to use C<Fatal> on a Perl built-in that can't be
+overridden, such as C<print> or C<system>, which means that
+C<Fatal> can't help you, although some other modules might.
+See the L</"SEE ALSO"> section of this documentation.
+
+=item Internal error: %s
+
+You've found a bug in C<Fatal>. Please report it using
+the C<perlbug> command.
+
+=back
+
+=head1 BUGS
+
+C<Fatal> clobbers the context in which a function is called and always
+makes it a scalar context, except when the C<:void> tag is used.
+This problem does not exist in L<autodie>.
+
+"Used only once" warnings can be generated when C<autodie> or C<Fatal>
+is used with package filehandles (eg, C<FILE>). It's strongly recommended
+you use scalar filehandles instead.
+
+=head1 AUTHOR
+
+Original module by Lionel Cons (CERN).
+
+Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
+
+L<autodie> support, bugfixes, extended diagnostics, C<system>
+support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
+
+=head1 LICENSE
+
+This module is free software, you may distribute it under the
+same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<autodie> for a nicer way to use lexical Fatal.
+
+L<IPC::System::Simple> for a similar idea for calls to C<system()>
+and backticks.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Fcntl.pm b/Master/tlpkg/tlperl/lib/Fcntl.pm
new file mode 100644
index 00000000000..83edeb60d85
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Fcntl.pm
@@ -0,0 +1,244 @@
+package Fcntl;
+
+=head1 NAME
+
+Fcntl - load the C Fcntl.h defines
+
+=head1 SYNOPSIS
+
+ use Fcntl;
+ use Fcntl qw(:DEFAULT :flock);
+
+=head1 DESCRIPTION
+
+This module is just a translation of the C F<fcntl.h> file.
+Unlike the old mechanism of requiring a translated F<fcntl.ph>
+file, this uses the B<h2xs> program (see the Perl source distribution)
+and your native C compiler. This means that it has a
+far more likely chance of getting the numbers right.
+
+=head1 NOTE
+
+Only C<#define> symbols get translated; you must still correctly
+pack up your own arguments to pass as args for locking functions, etc.
+
+=head1 EXPORTED SYMBOLS
+
+By default your system's F_* and O_* constants (eg, F_DUPFD and
+O_CREAT) and the FD_CLOEXEC constant are exported into your namespace.
+
+You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB
+and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>.
+
+You can request that the old constants (FAPPEND, FASYNC, FCREAT,
+FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for
+compatibility reasons by using the tag C<:Fcompat>. For new
+applications the newer versions of these constants are suggested
+(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK,
+O_SYNC, O_TRUNC).
+
+For ease of use also the SEEK_* constants (for seek() and sysseek(),
+e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are
+available for import. They can be imported either separately or using
+the tags C<:seek> and C<:mode>.
+
+Please refer to your native fcntl(2), open(2), fseek(3), lseek(2)
+(equal to Perl's seek() and sysseek(), respectively), and chmod(2)
+documentation to see what constants are implemented in your system.
+
+See L<perlopentut> to learn about the uses of the O_* constants
+with sysopen().
+
+See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants.
+
+See L<perlfunc/stat> about the S_I* constants.
+
+=cut
+
+use strict;
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD);
+
+require Exporter;
+use XSLoader ();
+@ISA = qw(Exporter);
+BEGIN {
+ $VERSION = "1.06";
+}
+
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+@EXPORT =
+ qw(
+ FD_CLOEXEC
+ F_ALLOCSP
+ F_ALLOCSP64
+ F_COMPAT
+ F_DUP2FD
+ F_DUPFD
+ F_EXLCK
+ F_FREESP
+ F_FREESP64
+ F_FSYNC
+ F_FSYNC64
+ F_GETFD
+ F_GETFL
+ F_GETLK
+ F_GETLK64
+ F_GETOWN
+ F_NODNY
+ F_POSIX
+ F_RDACC
+ F_RDDNY
+ F_RDLCK
+ F_RWACC
+ F_RWDNY
+ F_SETFD
+ F_SETFL
+ F_SETLK
+ F_SETLK64
+ F_SETLKW
+ F_SETLKW64
+ F_SETOWN
+ F_SHARE
+ F_SHLCK
+ F_UNLCK
+ F_UNSHARE
+ F_WRACC
+ F_WRDNY
+ F_WRLCK
+ O_ACCMODE
+ O_ALIAS
+ O_APPEND
+ O_ASYNC
+ O_BINARY
+ O_CREAT
+ O_DEFER
+ O_DIRECT
+ O_DIRECTORY
+ O_DSYNC
+ O_EXCL
+ O_EXLOCK
+ O_LARGEFILE
+ O_NDELAY
+ O_NOCTTY
+ O_NOFOLLOW
+ O_NOINHERIT
+ O_NONBLOCK
+ O_RANDOM
+ O_RAW
+ O_RDONLY
+ O_RDWR
+ O_RSRC
+ O_RSYNC
+ O_SEQUENTIAL
+ O_SHLOCK
+ O_SYNC
+ O_TEMPORARY
+ O_TEXT
+ O_TRUNC
+ O_WRONLY
+ );
+
+# Other items we are prepared to export if requested
+@EXPORT_OK = qw(
+ DN_ACCESS
+ DN_ATTRIB
+ DN_CREATE
+ DN_DELETE
+ DN_MODIFY
+ DN_MULTISHOT
+ DN_RENAME
+ FAPPEND
+ FASYNC
+ FCREAT
+ FDEFER
+ FDSYNC
+ FEXCL
+ FLARGEFILE
+ FNDELAY
+ FNONBLOCK
+ FRSYNC
+ FSYNC
+ FTRUNC
+ F_GETLEASE
+ F_GETSIG
+ F_NOTIFY
+ F_SETLEASE
+ F_SETSIG
+ LOCK_EX
+ LOCK_MAND
+ LOCK_NB
+ LOCK_READ
+ LOCK_RW
+ LOCK_SH
+ LOCK_UN
+ LOCK_WRITE
+ O_IGNORE_CTTY
+ O_NOATIME
+ O_NOLINK
+ O_NOTRANS
+ SEEK_CUR
+ SEEK_END
+ SEEK_SET
+ S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
+ S_IREAD S_IWRITE S_IEXEC
+ S_IRGRP S_IWGRP S_IXGRP S_IRWXG
+ S_IROTH S_IWOTH S_IXOTH S_IRWXO
+ S_IRUSR S_IWUSR S_IXUSR S_IRWXU
+ S_ISUID S_ISGID S_ISVTX S_ISTXT
+ _S_IFMT S_IFREG S_IFDIR S_IFLNK
+ &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO
+ &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE
+);
+# Named groups of exports
+%EXPORT_TAGS = (
+ 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)],
+ 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE
+ FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)],
+ 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)],
+ 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT
+ _S_IFMT S_IFREG S_IFDIR S_IFLNK
+ S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
+ S_IRUSR S_IWUSR S_IXUSR S_IRWXU
+ S_IRGRP S_IWGRP S_IXGRP S_IRWXG
+ S_IROTH S_IWOTH S_IXOTH S_IRWXO
+ S_IREAD S_IWRITE S_IEXEC
+ S_ISREG S_ISDIR S_ISLNK S_ISSOCK
+ S_ISBLK S_ISCHR S_ISFIFO
+ S_ISWHT S_ISENFMT
+ S_IFMT S_IMODE
+ )],
+);
+
+# Force the constants to become inlined
+BEGIN {
+ XSLoader::load 'Fcntl', $VERSION;
+}
+
+sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() }
+sub S_IMODE { $_[0] & 07777 }
+
+sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() }
+sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() }
+sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() }
+sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() }
+sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() }
+sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() }
+sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() }
+sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() }
+sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() }
+
+sub AUTOLOAD {
+ (my $constname = $AUTOLOAD) =~ s/.*:://;
+ die "&Fcntl::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ if ($error) {
+ my (undef,$file,$line) = caller;
+ die "$error at $file line $line.\n";
+ }
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ goto &$AUTOLOAD;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/FileCache.pm b/Master/tlpkg/tlperl/lib/FileCache.pm
new file mode 100644
index 00000000000..09583b04afa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/FileCache.pm
@@ -0,0 +1,188 @@
+package FileCache;
+
+our $VERSION = '1.08';
+
+=head1 NAME
+
+FileCache - keep more files open than the system permits
+
+=head1 SYNOPSIS
+
+ no strict 'refs';
+
+ use FileCache;
+ # or
+ use FileCache maxopen => 16;
+
+ cacheout $mode, $path;
+ # or
+ cacheout $path;
+ print $path @data;
+
+ $fh = cacheout $mode, $path;
+ # or
+ $fh = cacheout $path;
+ print $fh @data;
+
+=head1 DESCRIPTION
+
+The C<cacheout> function will make sure that there's a filehandle open
+for reading or writing available as the pathname you give it. It
+automatically closes and re-opens files if you exceed your system's
+maximum number of file descriptors, or the suggested maximum I<maxopen>.
+
+=over
+
+=item cacheout EXPR
+
+The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
+on it's first use, and appending (C<<< '>>' >>>) thereafter.
+
+Returns EXPR on success for convenience. You may neglect the
+return value and manipulate EXPR as the filehandle directly if you prefer.
+
+=item cacheout MODE, EXPR
+
+The 2-argument form of cacheout will use the supplied mode for the initial
+and subsequent openings. Most valid modes for 3-argument C<open> are supported
+namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
+C< '|-' > and C< '-|' >
+
+To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
+append them to the command string as you would system EXPR.
+
+Returns EXPR on success for convenience. You may neglect the
+return value and manipulate EXPR as the filehandle directly if you prefer.
+
+=back
+
+=head1 CAVEATS
+
+While it is permissible to C<close> a FileCache managed file,
+do not do so if you are calling C<FileCache::cacheout> from a package other
+than which it was imported, or with another module which overrides C<close>.
+If you must, use C<FileCache::cacheout_close>.
+
+Although FileCache can be used with piped opens ('-|' or '|-') doing so is
+strongly discouraged. If FileCache finds it necessary to close and then reopen
+a pipe, the command at the far end of the pipe will be reexecuted - the results
+of performing IO on FileCache'd pipes is unlikely to be what you expect. The
+ability to use FileCache on pipes may be removed in a future release.
+
+FileCache does not store the current file offset if it finds it necessary to
+close a file. When the file is reopened, the offset will be as specified by the
+original C<open> file mode. This could be construed to be a bug.
+
+The module functionality relies on symbolic references, so things will break
+under 'use strict' unless 'no strict "refs"' is also specified.
+
+=head1 BUGS
+
+F<sys/param.h> lies with its C<NOFILE> define on some systems,
+so you may have to set I<maxopen> yourself.
+
+=cut
+
+require 5.006;
+use Carp;
+use strict;
+no strict 'refs';
+
+# These are not C<my> for legacy reasons.
+# Previous versions requested the user set $cacheout_maxopen by hand.
+# Some authors fiddled with %saw to overcome the clobber on initial open.
+use vars qw(%saw $cacheout_maxopen);
+$cacheout_maxopen = 16;
+
+use base 'Exporter';
+our @EXPORT = qw[cacheout cacheout_close];
+
+
+my %isopen;
+my $cacheout_seq = 0;
+
+sub import {
+ my ($pkg,%args) = @_;
+
+ # Use Exporter. %args are for us, not Exporter.
+ # Make sure to up export_to_level, or we will import into ourselves,
+ # rather than our calling package;
+
+ __PACKAGE__->export_to_level(1);
+ Exporter::import( $pkg );
+
+ # Truth is okay here because setting maxopen to 0 would be bad
+ return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
+
+ # XXX This code is crazy. Why is it a one element foreach loop?
+ # Why is it using $param both as a filename and filehandle?
+ foreach my $param ( '/usr/include/sys/param.h' ){
+ if (open($param, '<', $param)) {
+ local ($_, $.);
+ while (<$param>) {
+ if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
+ $cacheout_maxopen = $1 - 4;
+ close($param);
+ last;
+ }
+ }
+ close $param;
+ }
+ }
+ $cacheout_maxopen ||= 16;
+}
+
+# Open in their package.
+sub cacheout_open {
+ return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
+}
+
+# Close in their package.
+sub cacheout_close {
+ # Short-circuit in case the filehandle disappeared
+ my $pkg = caller($_[1]||0);
+ defined fileno(*{$pkg . '::' . $_[0]}) &&
+ CORE::close(*{$pkg . '::' . $_[0]});
+ delete $isopen{$_[0]};
+}
+
+# But only this sub name is visible to them.
+sub cacheout {
+ my($mode, $file, $class, $ret, $ref, $narg);
+ croak "Not enough arguments for cacheout" unless $narg = scalar @_;
+ croak "Too many arguments for cacheout" if $narg > 2;
+
+ ($mode, $file) = @_;
+ ($file, $mode) = ($mode, $file) if $narg == 1;
+ croak "Invalid mode for cacheout" if $mode &&
+ ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
+
+ # Mode changed?
+ if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
+ &cacheout_close($file, 1);
+ }
+
+ if( $isopen{$file}) {
+ $ret = $file;
+ $isopen{$file}->[0]++;
+ }
+ else{
+ if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
+ my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
+ $cacheout_seq = 0;
+ $isopen{$_}->[0] = $cacheout_seq++ for
+ splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
+ &cacheout_close($_, 1) for @lru;
+ }
+
+ unless( $ref ){
+ $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
+ }
+ #XXX should we just return the value from cacheout_open, no croak?
+ $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
+
+ $isopen{$file} = [++$cacheout_seq, $mode];
+ }
+ return $ret;
+}
+1;
diff --git a/Master/tlpkg/tlperl/lib/FileHandle.pm b/Master/tlpkg/tlperl/lib/FileHandle.pm
new file mode 100644
index 00000000000..6b3636a089d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/FileHandle.pm
@@ -0,0 +1,262 @@
+package FileHandle;
+
+use 5.006;
+use strict;
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
+
+$VERSION = "2.02";
+
+require IO::File;
+@ISA = qw(IO::File);
+
+@EXPORT = qw(_IOFBF _IOLBF _IONBF);
+
+@EXPORT_OK = qw(
+ pipe
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+
+ print
+ printf
+ getline
+ getlines
+);
+
+#
+# Everything we're willing to export, we must first import.
+#
+import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK;
+
+#
+# Some people call "FileHandle::function", so all the functions
+# that were in the old FileHandle class must be imported, too.
+#
+{
+ no strict 'refs';
+
+ my %import = (
+ 'IO::Handle' =>
+ [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
+ eof flush error clearerr setbuf setvbuf _open_mode_string)],
+ 'IO::Seekable' =>
+ [qw(seek tell getpos setpos)],
+ 'IO::File' =>
+ [qw(new new_tmpfile open)]
+ );
+ for my $pkg (keys %import) {
+ for my $func (@{$import{$pkg}}) {
+ my $c = *{"${pkg}::$func"}{CODE}
+ or die "${pkg}::$func missing";
+ *$func = $c;
+ }
+ }
+}
+
+#
+# Specialized importer for Fcntl magic.
+#
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ require Exporter;
+ Exporter::export($pkg, $callpkg, @_);
+
+ #
+ # If the Fcntl extension is available,
+ # export its constants.
+ #
+ eval {
+ require Fcntl;
+ Exporter::export('Fcntl', $callpkg);
+ };
+}
+
+################################################
+# This is the only exported function we define;
+# the rest come from other classes.
+#
+
+sub pipe {
+ my $r = new IO::Handle;
+ my $w = new IO::Handle;
+ CORE::pipe($r, $w) or return undef;
+ ($r, $w);
+}
+
+# Rebless standard file handles
+bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
+bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
+bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
+
+1;
+
+__END__
+
+=head1 NAME
+
+FileHandle - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+ use FileHandle;
+
+ $fh = FileHandle->new;
+ if ($fh->open("< file")) {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = FileHandle->new("> FOO");
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = FileHandle->new("file", "r");
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = FileHandle->new("file", O_WRONLY|O_APPEND);
+ if (defined $fh) {
+ print $fh "corge\n";
+ undef $fh; # automatically closes the file
+ }
+
+ $pos = $fh->getpos;
+ $fh->setpos($pos);
+
+ $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+ ($readfh, $writefh) = FileHandle::pipe;
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+NOTE: This class is now a front-end to the IO::* classes.
+
+C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
+newly created symbol (see the C<Symbol> package). If it receives any
+parameters, they are passed to C<FileHandle::open>; if the open fails,
+the C<FileHandle> object is destroyed. Otherwise, it is returned to
+the caller.
+
+C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
+It requires two parameters, which are passed to C<FileHandle::fdopen>;
+if the fdopen fails, the C<FileHandle> object is destroyed.
+Otherwise, it is returned to the caller.
+
+C<FileHandle::open> accepts one parameter or two. With one parameter,
+it is just a front end for the built-in C<open> function. With two
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode, optionally followed by a file permission value.
+
+If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
+or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator.
+
+If C<FileHandle::open> is given a numeric mode, it passes that mode
+and the optional permissions value to the Perl C<sysopen> operator.
+For convenience, C<FileHandle::import> tries to import the O_XXX
+constants from the Fcntl module. If dynamic loading is not available,
+this may fail, but the rest of FileHandle will still work.
+
+C<FileHandle::fdopen> is like C<open> except that its first parameter
+is not a filename but rather a file handle name, a FileHandle object,
+or a file descriptor number.
+
+If the C functions fgetpos() and fsetpos() are available, then
+C<FileHandle::getpos> returns an opaque value that represents the
+current position of the FileHandle, and C<FileHandle::setpos> uses
+that value to return to a previously visited position.
+
+If the C function setvbuf() is available, then C<FileHandle::setvbuf>
+sets the buffering policy for the FileHandle. The calling sequence
+for the Perl function is the same as its C counterpart, including the
+macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
+parameter specifies a scalar variable to use as a buffer. WARNING: A
+variable used as a buffer by C<FileHandle::setvbuf> must not be
+modified in any way until the FileHandle is closed or until
+C<FileHandle::setvbuf> is called again, or memory corruption may
+result!
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<FileHandle> methods, which are just front ends for the
+corresponding built-in functions:
+
+ close
+ fileno
+ getc
+ gets
+ eof
+ clearerr
+ seek
+ tell
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<FileHandle> methods:
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+
+Furthermore, for doing normal I/O you might need these:
+
+=over 4
+
+=item $fh->print
+
+See L<perlfunc/print>.
+
+=item $fh->printf
+
+See L<perlfunc/printf>.
+
+=item $fh->getline
+
+This works like <$fh> described in L<perlop/"I/O Operators">
+except that it's more readable and can be safely called in a
+list context but still returns just one line.
+
+=item $fh->getlines
+
+This works like <$fh> when called in a list context to
+read all the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=back
+
+There are many other functions available since FileHandle is descended
+from IO::File, IO::Seekable, and IO::Handle. Please see those
+respective pages for documentation on more functions.
+
+=head1 SEE ALSO
+
+The B<IO> extension,
+L<perlfunc>,
+L<perlop/"I/O Operators">.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/FindBin.pm b/Master/tlpkg/tlperl/lib/FindBin.pm
new file mode 100644
index 00000000000..892d6e5d93a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/FindBin.pm
@@ -0,0 +1,209 @@
+# FindBin.pm
+#
+# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+=head1 NAME
+
+FindBin - Locate directory of original perl script
+
+=head1 SYNOPSIS
+
+ use FindBin;
+ use lib "$FindBin::Bin/../lib";
+
+ or
+
+ use FindBin qw($Bin);
+ use lib "$Bin/../lib";
+
+=head1 DESCRIPTION
+
+Locates the full path to the script bin directory to allow the use
+of paths relative to the bin directory.
+
+This allows a user to setup a directory tree for some software with
+directories C<< <root>/bin >> and C<< <root>/lib >>, and then the above
+example will allow the use of modules in the lib directory without knowing
+where the software tree is installed.
+
+If perl is invoked using the B<-e> option or the perl script is read from
+C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current
+directory.
+
+=head1 EXPORTABLE VARIABLES
+
+ $Bin - path to bin directory from where script was invoked
+ $Script - basename of script from which perl was invoked
+ $RealBin - $Bin with all links resolved
+ $RealScript - $Script with all links resolved
+
+=head1 KNOWN ISSUES
+
+If there are two modules using C<FindBin> from different directories
+under the same interpreter, this won't work. Since C<FindBin> uses a
+C<BEGIN> block, it'll be executed only once, and only the first caller
+will get it right. This is a problem under mod_perl and other persistent
+Perl environments, where you shouldn't use this module. Which also means
+that you should avoid using C<FindBin> in modules that you plan to put
+on CPAN. To make sure that C<FindBin> will work is to call the C<again>
+function:
+
+ use FindBin;
+ FindBin::again(); # or FindBin->again;
+
+In former versions of FindBin there was no C<again> function. The
+workaround was to force the C<BEGIN> block to be executed again:
+
+ delete $INC{'FindBin.pm'};
+ require FindBin;
+
+=head1 KNOWN BUGS
+
+If perl is invoked as
+
+ perl filename
+
+and I<filename> does not have executable rights and a program called
+I<filename> exists in the users C<$ENV{PATH}> which satisfies both B<-x>
+and B<-T> then FindBin assumes that it was invoked via the
+C<$ENV{PATH}>.
+
+Workaround is to invoke perl as
+
+ perl ./filename
+
+=head1 AUTHORS
+
+FindBin is supported as part of the core perl distribution. Please send bug
+reports to E<lt>F<perlbug@perl.org>E<gt> using the perlbug program
+included with perl.
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+package FindBin;
+use Carp;
+require 5.000;
+require Exporter;
+use Cwd qw(getcwd cwd abs_path);
+use File::Basename;
+use File::Spec;
+
+@EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
+%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
+@ISA = qw(Exporter);
+
+$VERSION = "1.50";
+
+
+# needed for VMS-specific filename translation
+if( $^O eq 'VMS' ) {
+ require VMS::Filespec;
+ VMS::Filespec->import;
+}
+
+sub cwd2 {
+ my $cwd = getcwd();
+ # getcwd might fail if it hasn't access to the current directory.
+ # try harder.
+ defined $cwd or $cwd = cwd();
+ $cwd;
+}
+
+sub init
+{
+ *Dir = \$Bin;
+ *RealDir = \$RealBin;
+
+ if($0 eq '-e' || $0 eq '-')
+ {
+ # perl invoked with -e or script is on C<STDIN>
+ $Script = $RealScript = $0;
+ $Bin = $RealBin = cwd2();
+ $Bin = VMS::Filespec::unixify($Bin) if $^O eq 'VMS';
+ }
+ else
+ {
+ my $script = $0;
+
+ if ($^O eq 'VMS')
+ {
+ ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*[\]>\/]+)(.*)/s;
+ # C<use disk:[dev]/lib> isn't going to work, so unixify first
+ ($Bin = VMS::Filespec::unixify($Bin)) =~ s/\/\z//;
+ ($RealBin,$RealScript) = ($Bin,$Script);
+ }
+ else
+ {
+ my $dosish = ($^O eq 'MSWin32' or $^O eq 'os2');
+ unless(($script =~ m#/# || ($dosish && $script =~ m#\\#))
+ && -f $script)
+ {
+ my $dir;
+ foreach $dir (File::Spec->path)
+ {
+ my $scr = File::Spec->catfile($dir, $script);
+
+ # $script can been found via PATH but perl could have
+ # been invoked as 'perl file'. Do a dumb check to see
+ # if $script is a perl program, if not then keep $script = $0
+ #
+ # well we actually only check that it is an ASCII file
+ # we know its executable so it is probably a script
+ # of some sort.
+ if(-f $scr && -r _ && ($dosish || -x _) && -s _ && -T _)
+ {
+ $script = $scr;
+ last;
+ }
+ }
+ }
+
+ croak("Cannot find current script '$0'") unless(-f $script);
+
+ # Ensure $script contains the complete path in case we C<chdir>
+
+ $script = File::Spec->catfile(cwd2(), $script)
+ unless File::Spec->file_name_is_absolute($script);
+
+ ($Script,$Bin) = fileparse($script);
+
+ # Resolve $script if it is a link
+ while(1)
+ {
+ my $linktext = readlink($script);
+
+ ($RealScript,$RealBin) = fileparse($script);
+ last unless defined $linktext;
+
+ $script = (File::Spec->file_name_is_absolute($linktext))
+ ? $linktext
+ : File::Spec->catfile($RealBin, $linktext);
+ }
+
+ # Get absolute paths to directories
+ if ($Bin) {
+ my $BinOld = $Bin;
+ $Bin = abs_path($Bin);
+ defined $Bin or $Bin = File::Spec->canonpath($BinOld);
+ }
+ $RealBin = abs_path($RealBin) if($RealBin);
+ }
+ }
+}
+
+BEGIN { init }
+
+*again = \&init;
+
+1; # Keep require happy
diff --git a/Master/tlpkg/tlperl/lib/IO.pm b/Master/tlpkg/tlperl/lib/IO.pm
new file mode 100644
index 00000000000..61e957c2fcc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/IO.pm
@@ -0,0 +1,68 @@
+#
+
+package IO;
+
+use XSLoader ();
+use Carp;
+use strict;
+use warnings;
+
+our $VERSION = "1.25_02";
+XSLoader::load 'IO', $VERSION;
+
+sub import {
+ shift;
+
+ warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated})
+ if @_ == 0 ;
+
+ my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
+
+ eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
+ or croak $@;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO - load various IO modules
+
+=head1 SYNOPSIS
+
+ use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File
+ use IO; # DEPRECATED
+
+=head1 DESCRIPTION
+
+C<IO> provides a simple mechanism to load several of the IO modules
+in one go. The IO modules belonging to the core are:
+
+ IO::Handle
+ IO::Seekable
+ IO::File
+ IO::Pipe
+ IO::Socket
+ IO::Dir
+ IO::Select
+ IO::Poll
+
+Some other IO modules don't belong to the perl core but can be loaded
+as well if they have been installed from CPAN. You can discover which
+ones exist by searching for "^IO::" on http://search.cpan.org.
+
+For more information on any of these modules, please see its respective
+documentation.
+
+=head1 DEPRECATED
+
+ use IO; # loads all the modules listed below
+
+The loaded modules are IO::Handle, IO::Seekable, IO::File, IO::Pipe,
+IO::Socket, IO::Dir. You should instead explicitly import the IO
+modules you want.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/Memoize.pm b/Master/tlpkg/tlperl/lib/Memoize.pm
new file mode 100644
index 00000000000..0cecbcab0a6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Memoize.pm
@@ -0,0 +1,1047 @@
+# -*- mode: perl; perl-indent-level: 2; -*-
+# Memoize.pm
+#
+# Transparent memoization of idempotent functions
+#
+# Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
+# You may copy and distribute this program under the
+# same terms as Perl itself. If in doubt,
+# write to mjd-perl-memoize+@plover.com for a license.
+#
+# Version 1.01 $Revision: 1.18 $ $Date: 2001/06/24 17:16:47 $
+
+package Memoize;
+$VERSION = '1.01_03';
+
+# Compile-time constants
+sub SCALAR () { 0 }
+sub LIST () { 1 }
+
+
+#
+# Usage memoize(functionname/ref,
+# { NORMALIZER => coderef, INSTALL => name,
+# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor }
+#
+
+use Carp;
+use Exporter;
+use vars qw($DEBUG);
+use Config; # Dammit.
+@ISA = qw(Exporter);
+@EXPORT = qw(memoize);
+@EXPORT_OK = qw(unmemoize flush_cache);
+use strict;
+
+my %memotable;
+my %revmemotable;
+my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
+my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;
+
+# Raise an error if the user tries to specify one of thesepackage as a
+# tie for LIST_CACHE
+
+my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
+
+sub memoize {
+ my $fn = shift;
+ my %options = @_;
+ my $options = \%options;
+
+ unless (defined($fn) &&
+ (ref $fn eq 'CODE' || ref $fn eq '')) {
+ croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
+ }
+
+ my $uppack = caller; # TCL me Elmo!
+ my $cref; # Code reference to original function
+ my $name = (ref $fn ? undef : $fn);
+
+ # Convert function names to code references
+ $cref = &_make_cref($fn, $uppack);
+
+ # Locate function prototype, if any
+ my $proto = prototype $cref;
+ if (defined $proto) { $proto = "($proto)" }
+ else { $proto = "" }
+
+ # I would like to get rid of the eval, but there seems not to be any
+ # other way to set the prototype properly. The switch here for
+ # 'usethreads' works around a bug in threadperl having to do with
+ # magic goto. It would be better to fix the bug and use the magic
+ # goto version everywhere.
+ my $wrapper =
+ $Config{usethreads}
+ ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
+ : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
+
+ my $normalizer = $options{NORMALIZER};
+ if (defined $normalizer && ! ref $normalizer) {
+ $normalizer = _make_cref($normalizer, $uppack);
+ }
+
+ my $install_name;
+ if (defined $options->{INSTALL}) {
+ # INSTALL => name
+ $install_name = $options->{INSTALL};
+ } elsif (! exists $options->{INSTALL}) {
+ # No INSTALL option provided; use original name if possible
+ $install_name = $name;
+ } else {
+ # INSTALL => undef means don't install
+ }
+
+ if (defined $install_name) {
+ $install_name = $uppack . '::' . $install_name
+ unless $install_name =~ /::/;
+ no strict;
+ local($^W) = 0; # ``Subroutine $install_name redefined at ...''
+ *{$install_name} = $wrapper; # Install memoized version
+ }
+
+ $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
+
+ # These will be the caches
+ my %caches;
+ for my $context (qw(SCALAR LIST)) {
+ # suppress subsequent 'uninitialized value' warnings
+ $options{"${context}_CACHE"} ||= '';
+
+ my $cache_opt = $options{"${context}_CACHE"};
+ my @cache_opt_args;
+ if (ref $cache_opt) {
+ @cache_opt_args = @$cache_opt;
+ $cache_opt = shift @cache_opt_args;
+ }
+ if ($cache_opt eq 'FAULT') { # no cache
+ $caches{$context} = undef;
+ } elsif ($cache_opt eq 'HASH') { # user-supplied hash
+ my $cache = $cache_opt_args[0];
+ my $package = ref(tied %$cache);
+ if ($context eq 'LIST' && $scalar_only{$package}) {
+ croak("You can't use $package for LIST_CACHE because it can only store scalars");
+ }
+ $caches{$context} = $cache;
+ } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) {
+ # default is that we make up an in-memory hash
+ $caches{$context} = {};
+ # (this might get tied later, or MERGEd away)
+ } else {
+ croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting";
+ }
+ }
+
+ # Perhaps I should check here that you didn't supply *both* merge
+ # options. But if you did, it does do something reasonable: They
+ # both get merged to the same in-memory hash.
+ if ($options{SCALAR_CACHE} eq 'MERGE') {
+ $caches{SCALAR} = $caches{LIST};
+ } elsif ($options{LIST_CACHE} eq 'MERGE') {
+ $caches{LIST} = $caches{SCALAR};
+ }
+
+ # Now deal with the TIE options
+ {
+ my $context;
+ foreach $context (qw(SCALAR LIST)) {
+ # If the relevant option wasn't `TIE', this call does nothing.
+ _my_tie($context, $caches{$context}, $options); # Croaks on failure
+ }
+ }
+
+ # We should put some more stuff in here eventually.
+ # We've been saying that for serveral versions now.
+ # And you know what? More stuff keeps going in!
+ $memotable{$cref} =
+ {
+ O => $options, # Short keys here for things we need to access frequently
+ N => $normalizer,
+ U => $cref,
+ MEMOIZED => $wrapper,
+ PACKAGE => $uppack,
+ NAME => $install_name,
+ S => $caches{SCALAR},
+ L => $caches{LIST},
+ };
+
+ $wrapper # Return just memoized version
+}
+
+# This function tries to load a tied hash class and tie the hash to it.
+sub _my_tie {
+ my ($context, $hash, $options) = @_;
+ my $fullopt = $options->{"${context}_CACHE"};
+
+ # We already checked to make sure that this works.
+ my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
+
+ return unless defined $shortopt && $shortopt eq 'TIE';
+ carp("TIE option to memoize() is deprecated; use HASH instead")
+ if $^W;
+
+ my @args = ref $fullopt ? @$fullopt : ();
+ shift @args;
+ my $module = shift @args;
+ if ($context eq 'LIST' && $scalar_only{$module}) {
+ croak("You can't use $module for LIST_CACHE because it can only store scalars");
+ }
+ my $modulefile = $module . '.pm';
+ $modulefile =~ s{::}{/}g;
+ eval { require $modulefile };
+ if ($@) {
+ croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
+ }
+ my $rc = (tie %$hash => $module, @args);
+ unless ($rc) {
+ croak "Memoize: Couldn't tie hash to `$module': $!; aborting";
+ }
+ 1;
+}
+
+sub flush_cache {
+ my $func = _make_cref($_[0], scalar caller);
+ my $info = $memotable{$revmemotable{$func}};
+ die "$func not memoized" unless defined $info;
+ for my $context (qw(S L)) {
+ my $cache = $info->{$context};
+ if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
+ my $funcname = defined($info->{NAME}) ?
+ "function $info->{NAME}" : "anonymous function $func";
+ my $context = {S => 'scalar', L => 'list'}->{$context};
+ croak "Tied cache hash for $context-context $funcname does not support flushing";
+ } else {
+ %$cache = ();
+ }
+ }
+}
+
+# This is the function that manages the memo tables.
+sub _memoizer {
+ my $orig = shift; # stringized version of ref to original func.
+ my $info = $memotable{$orig};
+ my $normalizer = $info->{N};
+
+ my $argstr;
+ my $context = (wantarray() ? LIST : SCALAR);
+
+ if (defined $normalizer) {
+ no strict;
+ if ($context == SCALAR) {
+ $argstr = &{$normalizer}(@_);
+ } elsif ($context == LIST) {
+ ($argstr) = &{$normalizer}(@_);
+ } else {
+ croak "Internal error \#41; context was neither LIST nor SCALAR\n";
+ }
+ } else { # Default normalizer
+ local $^W = 0;
+ $argstr = join chr(28),@_;
+ }
+
+ if ($context == SCALAR) {
+ my $cache = $info->{S};
+ _crap_out($info->{NAME}, 'scalar') unless $cache;
+ if (exists $cache->{$argstr}) {
+ return $cache->{$argstr};
+ } else {
+ my $val = &{$info->{U}}(@_);
+ # Scalars are considered to be lists; store appropriately
+ if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
+ $cache->{$argstr} = [$val];
+ } else {
+ $cache->{$argstr} = $val;
+ }
+ $val;
+ }
+ } elsif ($context == LIST) {
+ my $cache = $info->{L};
+ _crap_out($info->{NAME}, 'list') unless $cache;
+ if (exists $cache->{$argstr}) {
+ my $val = $cache->{$argstr};
+ # If LISTCONTEXT=>MERGE, then the function never returns lists,
+ # so we have a scalar value cached, so just return it straightaway:
+ return ($val) if $info->{O}{LIST_CACHE} eq 'MERGE';
+ # Maybe in a later version we can use a faster test.
+
+ # Otherwise, we cached an array containing the returned list:
+ return @$val;
+ } else {
+ my @q = &{$info->{U}}(@_);
+ $cache->{$argstr} = $info->{O}{LIST_CACHE} eq 'MERGE' ? $q [0] : \@q;
+ @q;
+ }
+ } else {
+ croak "Internal error \#42; context was neither LIST nor SCALAR\n";
+ }
+}
+
+sub unmemoize {
+ my $f = shift;
+ my $uppack = caller;
+ my $cref = _make_cref($f, $uppack);
+
+ unless (exists $revmemotable{$cref}) {
+ croak "Could not unmemoize function `$f', because it was not memoized to begin with";
+ }
+
+ my $tabent = $memotable{$revmemotable{$cref}};
+ unless (defined $tabent) {
+ croak "Could not figure out how to unmemoize function `$f'";
+ }
+ my $name = $tabent->{NAME};
+ if (defined $name) {
+ no strict;
+ local($^W) = 0; # ``Subroutine $install_name redefined at ...''
+ *{$name} = $tabent->{U}; # Replace with original function
+ }
+ undef $memotable{$revmemotable{$cref}};
+ undef $revmemotable{$cref};
+
+ # This removes the last reference to the (possibly tied) memo tables
+ # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'};
+ # undef $tabent;
+
+# # Untie the memo tables if they were tied.
+# my $i;
+# for $i (0,1) {
+# if (tied %{$memotabs->[$i]}) {
+# warn "Untying hash #$i\n";
+# untie %{$memotabs->[$i]};
+# }
+# }
+
+ $tabent->{U};
+}
+
+sub _make_cref {
+ my $fn = shift;
+ my $uppack = shift;
+ my $cref;
+ my $name;
+
+ if (ref $fn eq 'CODE') {
+ $cref = $fn;
+ } elsif (! ref $fn) {
+ if ($fn =~ /::/) {
+ $name = $fn;
+ } else {
+ $name = $uppack . '::' . $fn;
+ }
+ no strict;
+ if (defined $name and !defined(&$name)) {
+ croak "Cannot operate on nonexistent function `$fn'";
+ }
+# $cref = \&$name;
+ $cref = *{$name}{CODE};
+ } else {
+ my $parent = (caller(1))[3]; # Function that called _make_cref
+ croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
+ }
+ $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
+ $cref;
+}
+
+sub _crap_out {
+ my ($funcname, $context) = @_;
+ if (defined $funcname) {
+ croak "Function `$funcname' called in forbidden $context context; faulting";
+ } else {
+ croak "Anonymous function called in forbidden $context context; faulting";
+ }
+}
+
+1;
+
+
+
+
+
+=head1 NAME
+
+Memoize - Make functions faster by trading space for time
+
+=head1 SYNOPSIS
+
+ # This is the documentation for Memoize 1.01
+ use Memoize;
+ memoize('slow_function');
+ slow_function(arguments); # Is faster than it was before
+
+
+This is normally all you need to know. However, many options are available:
+
+ memoize(function, options...);
+
+Options include:
+
+ NORMALIZER => function
+ INSTALL => new_name
+
+ SCALAR_CACHE => 'MEMORY'
+ SCALAR_CACHE => ['HASH', \%cache_hash ]
+ SCALAR_CACHE => 'FAULT'
+ SCALAR_CACHE => 'MERGE'
+
+ LIST_CACHE => 'MEMORY'
+ LIST_CACHE => ['HASH', \%cache_hash ]
+ LIST_CACHE => 'FAULT'
+ LIST_CACHE => 'MERGE'
+
+=head1 DESCRIPTION
+
+`Memoizing' a function makes it faster by trading space for time. It
+does this by caching the return values of the function in a table.
+If you call the function again with the same arguments, C<memoize>
+jumps in and gives you the value out of the table, instead of letting
+the function compute the value all over again.
+
+Here is an extreme example. Consider the Fibonacci sequence, defined
+by the following function:
+
+ # Compute Fibonacci numbers
+ sub fib {
+ my $n = shift;
+ return $n if $n < 2;
+ fib($n-1) + fib($n-2);
+ }
+
+This function is very slow. Why? To compute fib(14), it first wants
+to compute fib(13) and fib(12), and add the results. But to compute
+fib(13), it first has to compute fib(12) and fib(11), and then it
+comes back and computes fib(12) all over again even though the answer
+is the same. And both of the times that it wants to compute fib(12),
+it has to compute fib(11) from scratch, and then it has to do it
+again each time it wants to compute fib(13). This function does so
+much recomputing of old results that it takes a really long time to
+run---fib(14) makes 1,200 extra recursive calls to itself, to compute
+and recompute things that it already computed.
+
+This function is a good candidate for memoization. If you memoize the
+`fib' function above, it will compute fib(14) exactly once, the first
+time it needs to, and then save the result in a table. Then if you
+ask for fib(14) again, it gives you the result out of the table.
+While computing fib(14), instead of computing fib(12) twice, it does
+it once; the second time it needs the value it gets it from the table.
+It doesn't compute fib(11) four times; it computes it once, getting it
+from the table the next three times. Instead of making 1,200
+recursive calls to `fib', it makes 15. This makes the function about
+150 times faster.
+
+You could do the memoization yourself, by rewriting the function, like
+this:
+
+ # Compute Fibonacci numbers, memoized version
+ { my @fib;
+ sub fib {
+ my $n = shift;
+ return $fib[$n] if defined $fib[$n];
+ return $fib[$n] = $n if $n < 2;
+ $fib[$n] = fib($n-1) + fib($n-2);
+ }
+ }
+
+Or you could use this module, like this:
+
+ use Memoize;
+ memoize('fib');
+
+ # Rest of the fib function just like the original version.
+
+This makes it easy to turn memoizing on and off.
+
+Here's an even simpler example: I wrote a simple ray tracer; the
+program would look in a certain direction, figure out what it was
+looking at, and then convert the `color' value (typically a string
+like `red') of that object to a red, green, and blue pixel value, like
+this:
+
+ for ($direction = 0; $direction < 300; $direction++) {
+ # Figure out which object is in direction $direction
+ $color = $object->{color};
+ ($r, $g, $b) = @{&ColorToRGB($color)};
+ ...
+ }
+
+Since there are relatively few objects in a picture, there are only a
+few colors, which get looked up over and over again. Memoizing
+C<ColorToRGB> sped up the program by several percent.
+
+=head1 DETAILS
+
+This module exports exactly one function, C<memoize>. The rest of the
+functions in this package are None of Your Business.
+
+You should say
+
+ memoize(function)
+
+where C<function> is the name of the function you want to memoize, or
+a reference to it. C<memoize> returns a reference to the new,
+memoized version of the function, or C<undef> on a non-fatal error.
+At present, there are no non-fatal errors, but there might be some in
+the future.
+
+If C<function> was the name of a function, then C<memoize> hides the
+old version and installs the new memoized version under the old name,
+so that C<&function(...)> actually invokes the memoized version.
+
+=head1 OPTIONS
+
+There are some optional options you can pass to C<memoize> to change
+the way it behaves a little. To supply options, invoke C<memoize>
+like this:
+
+ memoize(function, NORMALIZER => function,
+ INSTALL => newname,
+ SCALAR_CACHE => option,
+ LIST_CACHE => option
+ );
+
+Each of these options is optional; you can include some, all, or none
+of them.
+
+=head2 INSTALL
+
+If you supply a function name with C<INSTALL>, memoize will install
+the new, memoized version of the function under the name you give.
+For example,
+
+ memoize('fib', INSTALL => 'fastfib')
+
+installs the memoized version of C<fib> as C<fastfib>; without the
+C<INSTALL> option it would have replaced the old C<fib> with the
+memoized version.
+
+To prevent C<memoize> from installing the memoized version anywhere, use
+C<INSTALL =E<gt> undef>.
+
+=head2 NORMALIZER
+
+Suppose your function looks like this:
+
+ # Typical call: f('aha!', A => 11, B => 12);
+ sub f {
+ my $a = shift;
+ my %hash = @_;
+ $hash{B} ||= 2; # B defaults to 2
+ $hash{C} ||= 7; # C defaults to 7
+
+ # Do something with $a, %hash
+ }
+
+Now, the following calls to your function are all completely equivalent:
+
+ f(OUCH);
+ f(OUCH, B => 2);
+ f(OUCH, C => 7);
+ f(OUCH, B => 2, C => 7);
+ f(OUCH, C => 7, B => 2);
+ (etc.)
+
+However, unless you tell C<Memoize> that these calls are equivalent,
+it will not know that, and it will compute the values for these
+invocations of your function separately, and store them separately.
+
+To prevent this, supply a C<NORMALIZER> function that turns the
+program arguments into a string in a way that equivalent arguments
+turn into the same string. A C<NORMALIZER> function for C<f> above
+might look like this:
+
+ sub normalize_f {
+ my $a = shift;
+ my %hash = @_;
+ $hash{B} ||= 2;
+ $hash{C} ||= 7;
+
+ join(',', $a, map ($_ => $hash{$_}) sort keys %hash);
+ }
+
+Each of the argument lists above comes out of the C<normalize_f>
+function looking exactly the same, like this:
+
+ OUCH,B,2,C,7
+
+You would tell C<Memoize> to use this normalizer this way:
+
+ memoize('f', NORMALIZER => 'normalize_f');
+
+C<memoize> knows that if the normalized version of the arguments is
+the same for two argument lists, then it can safely look up the value
+that it computed for one argument list and return it as the result of
+calling the function with the other argument list, even if the
+argument lists look different.
+
+The default normalizer just concatenates the arguments with character
+28 in between. (In ASCII, this is called FS or control-\.) This
+always works correctly for functions with only one string argument,
+and also when the arguments never contain character 28. However, it
+can confuse certain argument lists:
+
+ normalizer("a\034", "b")
+ normalizer("a", "\034b")
+ normalizer("a\034\034b")
+
+for example.
+
+Since hash keys are strings, the default normalizer will not
+distinguish between C<undef> and the empty string. It also won't work
+when the function's arguments are references. For example, consider a
+function C<g> which gets two arguments: A number, and a reference to
+an array of numbers:
+
+ g(13, [1,2,3,4,5,6,7]);
+
+The default normalizer will turn this into something like
+C<"13\034ARRAY(0x436c1f)">. That would be all right, except that a
+subsequent array of numbers might be stored at a different location
+even though it contains the same data. If this happens, C<Memoize>
+will think that the arguments are different, even though they are
+equivalent. In this case, a normalizer like this is appropriate:
+
+ sub normalize { join ' ', $_[0], @{$_[1]} }
+
+For the example above, this produces the key "13 1 2 3 4 5 6 7".
+
+Another use for normalizers is when the function depends on data other
+than those in its arguments. Suppose you have a function which
+returns a value which depends on the current hour of the day:
+
+ sub on_duty {
+ my ($problem_type) = @_;
+ my $hour = (localtime)[2];
+ open my $fh, "$DIR/$problem_type" or die...;
+ my $line;
+ while ($hour-- > 0)
+ $line = <$fh>;
+ }
+ return $line;
+ }
+
+At 10:23, this function generates the 10th line of a data file; at
+3:45 PM it generates the 15th line instead. By default, C<Memoize>
+will only see the $problem_type argument. To fix this, include the
+current hour in the normalizer:
+
+ sub normalize { join ' ', (localtime)[2], @_ }
+
+The calling context of the function (scalar or list context) is
+propagated to the normalizer. This means that if the memoized
+function will treat its arguments differently in list context than it
+would in scalar context, you can have the normalizer function select
+its behavior based on the results of C<wantarray>. Even if called in
+a list context, a normalizer should still return a single string.
+
+=head2 C<SCALAR_CACHE>, C<LIST_CACHE>
+
+Normally, C<Memoize> caches your function's return values into an
+ordinary Perl hash variable. However, you might like to have the
+values cached on the disk, so that they persist from one run of your
+program to the next, or you might like to associate some other
+interesting semantics with the cached values.
+
+There's a slight complication under the hood of C<Memoize>: There are
+actually I<two> caches, one for scalar values and one for list values.
+When your function is called in scalar context, its return value is
+cached in one hash, and when your function is called in list context,
+its value is cached in the other hash. You can control the caching
+behavior of both contexts independently with these options.
+
+The argument to C<LIST_CACHE> or C<SCALAR_CACHE> must either be one of
+the following four strings:
+
+ MEMORY
+ FAULT
+ MERGE
+ HASH
+
+or else it must be a reference to a list whose first element is one of
+these four strings, such as C<[HASH, arguments...]>.
+
+=over 4
+
+=item C<MEMORY>
+
+C<MEMORY> means that return values from the function will be cached in
+an ordinary Perl hash variable. The hash variable will not persist
+after the program exits. This is the default.
+
+=item C<HASH>
+
+C<HASH> allows you to specify that a particular hash that you supply
+will be used as the cache. You can tie this hash beforehand to give
+it any behavior you want.
+
+A tied hash can have any semantics at all. It is typically tied to an
+on-disk database, so that cached values are stored in the database and
+retrieved from it again when needed, and the disk file typically
+persists after your program has exited. See C<perltie> for more
+complete details about C<tie>.
+
+A typical example is:
+
+ use DB_File;
+ tie my %cache => 'DB_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+This has the effect of storing the cache in a C<DB_File> database
+whose name is in C<$filename>. The cache will persist after the
+program has exited. Next time the program runs, it will find the
+cache already populated from the previous run of the program. Or you
+can forcibly populate the cache by constructing a batch program that
+runs in the background and populates the cache file. Then when you
+come to run your real program the memoized function will be fast
+because all its results have been precomputed.
+
+=item C<TIE>
+
+This option is no longer supported. It is still documented only to
+aid in the debugging of old programs that use it. Old programs should
+be converted to use the C<HASH> option instead.
+
+ memoize ... [TIE, PACKAGE, ARGS...]
+
+is merely a shortcut for
+
+ require PACKAGE;
+ { my %cache;
+ tie %cache, PACKAGE, ARGS...;
+ }
+ memoize ... [HASH => \%cache];
+
+=item C<FAULT>
+
+C<FAULT> means that you never expect to call the function in scalar
+(or list) context, and that if C<Memoize> detects such a call, it
+should abort the program. The error message is one of
+
+ `foo' function called in forbidden list context at line ...
+ `foo' function called in forbidden scalar context at line ...
+
+=item C<MERGE>
+
+C<MERGE> normally means the function does not distinguish between list
+and sclar context, and that return values in both contexts should be
+stored together. C<LIST_CACHE =E<gt> MERGE> means that list context
+return values should be stored in the same hash that is used for
+scalar context returns, and C<SCALAR_CACHE =E<gt> MERGE> means the
+same, mutatis mutandis. It is an error to specify C<MERGE> for both,
+but it probably does something useful.
+
+Consider this function:
+
+ sub pi { 3; }
+
+Normally, the following code will result in two calls to C<pi>:
+
+ $x = pi();
+ ($y) = pi();
+ $z = pi();
+
+The first call caches the value C<3> in the scalar cache; the second
+caches the list C<(3)> in the list cache. The third call doesn't call
+the real C<pi> function; it gets the value from the scalar cache.
+
+Obviously, the second call to C<pi> is a waste of time, and storing
+its return value is a waste of space. Specifying C<LIST_CACHE =E<gt>
+MERGE> will make C<memoize> use the same cache for scalar and list
+context return values, so that the second call uses the scalar cache
+that was populated by the first call. C<pi> ends up being called only
+once, and both subsequent calls return C<3> from the cache, regardless
+of the calling context.
+
+Another use for C<MERGE> is when you want both kinds of return values
+stored in the same disk file; this saves you from having to deal with
+two disk files instead of one. You can use a normalizer function to
+keep the two sets of return values separate. For example:
+
+ tie my %cache => 'MLDBM', 'DB_File', $filename, ...;
+
+ memoize 'myfunc',
+ NORMALIZER => 'n',
+ SCALAR_CACHE => [HASH => \%cache],
+ LIST_CACHE => MERGE,
+ ;
+
+ sub n {
+ my $context = wantarray() ? 'L' : 'S';
+ # ... now compute the hash key from the arguments ...
+ $hashkey = "$context:$hashkey";
+ }
+
+This normalizer function will store scalar context return values in
+the disk file under keys that begin with C<S:>, and list context
+return values under keys that begin with C<L:>.
+
+=back
+
+=head1 OTHER FACILITIES
+
+=head2 C<unmemoize>
+
+There's an C<unmemoize> function that you can import if you want to.
+Why would you want to? Here's an example: Suppose you have your cache
+tied to a DBM file, and you want to make sure that the cache is
+written out to disk if someone interrupts the program. If the program
+exits normally, this will happen anyway, but if someone types
+control-C or something then the program will terminate immediately
+without synchronizing the database. So what you can do instead is
+
+ $SIG{INT} = sub { unmemoize 'function' };
+
+C<unmemoize> accepts a reference to, or the name of a previously
+memoized function, and undoes whatever it did to provide the memoized
+version in the first place, including making the name refer to the
+unmemoized version if appropriate. It returns a reference to the
+unmemoized version of the function.
+
+If you ask it to unmemoize a function that was never memoized, it
+croaks.
+
+=head2 C<flush_cache>
+
+C<flush_cache(function)> will flush out the caches, discarding I<all>
+the cached data. The argument may be a function name or a reference
+to a function. For finer control over when data is discarded or
+expired, see the documentation for C<Memoize::Expire>, included in
+this package.
+
+Note that if the cache is a tied hash, C<flush_cache> will attempt to
+invoke the C<CLEAR> method on the hash. If there is no C<CLEAR>
+method, this will cause a run-time error.
+
+An alternative approach to cache flushing is to use the C<HASH> option
+(see above) to request that C<Memoize> use a particular hash variable
+as its cache. Then you can examine or modify the hash at any time in
+any way you desire. You may flush the cache by using C<%hash = ()>.
+
+=head1 CAVEATS
+
+Memoization is not a cure-all:
+
+=over 4
+
+=item *
+
+Do not memoize a function whose behavior depends on program
+state other than its own arguments, such as global variables, the time
+of day, or file input. These functions will not produce correct
+results when memoized. For a particularly easy example:
+
+ sub f {
+ time;
+ }
+
+This function takes no arguments, and as far as C<Memoize> is
+concerned, it always returns the same result. C<Memoize> is wrong, of
+course, and the memoized version of this function will call C<time> once
+to get the current time, and it will return that same time
+every time you call it after that.
+
+=item *
+
+Do not memoize a function with side effects.
+
+ sub f {
+ my ($a, $b) = @_;
+ my $s = $a + $b;
+ print "$a + $b = $s.\n";
+ }
+
+This function accepts two arguments, adds them, and prints their sum.
+Its return value is the numuber of characters it printed, but you
+probably didn't care about that. But C<Memoize> doesn't understand
+that. If you memoize this function, you will get the result you
+expect the first time you ask it to print the sum of 2 and 3, but
+subsequent calls will return 1 (the return value of
+C<print>) without actually printing anything.
+
+=item *
+
+Do not memoize a function that returns a data structure that is
+modified by its caller.
+
+Consider these functions: C<getusers> returns a list of users somehow,
+and then C<main> throws away the first user on the list and prints the
+rest:
+
+ sub main {
+ my $userlist = getusers();
+ shift @$userlist;
+ foreach $u (@$userlist) {
+ print "User $u\n";
+ }
+ }
+
+ sub getusers {
+ my @users;
+ # Do something to get a list of users;
+ \@users; # Return reference to list.
+ }
+
+If you memoize C<getusers> here, it will work right exactly once. The
+reference to the users list will be stored in the memo table. C<main>
+will discard the first element from the referenced list. The next
+time you invoke C<main>, C<Memoize> will not call C<getusers>; it will
+just return the same reference to the same list it got last time. But
+this time the list has already had its head removed; C<main> will
+erroneously remove another element from it. The list will get shorter
+and shorter every time you call C<main>.
+
+Similarly, this:
+
+ $u1 = getusers();
+ $u2 = getusers();
+ pop @$u1;
+
+will modify $u2 as well as $u1, because both variables are references
+to the same array. Had C<getusers> not been memoized, $u1 and $u2
+would have referred to different arrays.
+
+=item *
+
+Do not memoize a very simple function.
+
+Recently someone mentioned to me that the Memoize module made his
+program run slower instead of faster. It turned out that he was
+memoizing the following function:
+
+ sub square {
+ $_[0] * $_[0];
+ }
+
+I pointed out that C<Memoize> uses a hash, and that looking up a
+number in the hash is necessarily going to take a lot longer than a
+single multiplication. There really is no way to speed up the
+C<square> function.
+
+Memoization is not magical.
+
+=back
+
+=head1 PERSISTENT CACHE SUPPORT
+
+You can tie the cache tables to any sort of tied hash that you want
+to, as long as it supports C<TIEHASH>, C<FETCH>, C<STORE>, and
+C<EXISTS>. For example,
+
+ tie my %cache => 'GDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+works just fine. For some storage methods, you need a little glue.
+
+C<SDBM_File> doesn't supply an C<EXISTS> method, so included in this
+package is a glue module called C<Memoize::SDBM_File> which does
+provide one. Use this instead of plain C<SDBM_File> to store your
+cache table on disk in an C<SDBM_File> database:
+
+ tie my %cache => 'Memoize::SDBM_File', $filename, O_RDWR|O_CREAT, 0666;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+C<NDBM_File> has the same problem and the same solution. (Use
+C<Memoize::NDBM_File instead of plain NDBM_File.>)
+
+C<Storable> isn't a tied hash class at all. You can use it to store a
+hash to disk and retrieve it again, but you can't modify the hash while
+it's on the disk. So if you want to store your cache table in a
+C<Storable> database, use C<Memoize::Storable>, which puts a hashlike
+front-end onto C<Storable>. The hash table is actually kept in
+memory, and is loaded from your C<Storable> file at the time you
+memoize the function, and stored back at the time you unmemoize the
+function (or when your program exits):
+
+ tie my %cache => 'Memoize::Storable', $filename;
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+ tie my %cache => 'Memoize::Storable', $filename, 'nstore';
+ memoize 'function', SCALAR_CACHE => [HASH => \%cache];
+
+Include the `nstore' option to have the C<Storable> database written
+in `network order'. (See L<Storable> for more details about this.)
+
+The C<flush_cache()> function will raise a run-time error unless the
+tied package provides a C<CLEAR> method.
+
+=head1 EXPIRATION SUPPORT
+
+See Memoize::Expire, which is a plug-in module that adds expiration
+functionality to Memoize. If you don't like the kinds of policies
+that Memoize::Expire implements, it is easy to write your own plug-in
+module to implement whatever policy you desire. Memoize comes with
+several examples. An expiration manager that implements a LRU policy
+is available on CPAN as Memoize::ExpireLRU.
+
+=head1 BUGS
+
+The test suite is much better, but always needs improvement.
+
+There is some problem with the way C<goto &f> works under threaded
+Perl, perhaps because of the lexical scoping of C<@_>. This is a bug
+in Perl, and until it is resolved, memoized functions will see a
+slightly different C<caller()> and will perform a little more slowly
+on threaded perls than unthreaded perls.
+
+Some versions of C<DB_File> won't let you store data under a key of
+length 0. That means that if you have a function C<f> which you
+memoized and the cache is in a C<DB_File> database, then the value of
+C<f()> (C<f> called with no arguments) will not be memoized. If this
+is a big problem, you can supply a normalizer function that prepends
+C<"x"> to every key.
+
+=head1 MAILING LIST
+
+To join a very low-traffic mailing list for announcements about
+C<Memoize>, send an empty note to C<mjd-perl-memoize-request@plover.com>.
+
+=head1 AUTHOR
+
+Mark-Jason Dominus (C<mjd-perl-memoize+@plover.com>), Plover Systems co.
+
+See the C<Memoize.pm> Page at http://www.plover.com/~mjd/perl/Memoize/
+for news and upgrades. Near this page, at
+http://www.plover.com/~mjd/perl/MiniMemoize/ there is an article about
+memoization and about the internals of Memoize that appeared in The
+Perl Journal, issue #13. (This article is also included in the
+Memoize distribution as `article.html'.)
+
+The author's book I<Higher Order Perl> (2005, ISBN 1558607013, published
+by Morgan Kaufmann) discusses memoization (and many other fascinating
+topics) in tremendous detail. It will also be available on-line for free.
+For more information, visit http://perl.plover.com/book/ .
+
+To join a mailing list for announcements about C<Memoize>, send an
+empty message to C<mjd-perl-memoize-request@plover.com>. This mailing
+list is for announcements only and has extremely low traffic---about
+two messages per year.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1998, 1999, 2000, 2001 by Mark Jason Dominus
+
+This library is free software; you may redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 THANK YOU
+
+Many thanks to Jonathan Roy for bug reports and suggestions, to
+Michael Schwern for other bug reports and patches, to Mike Cariaso for
+helping me to figure out the Right Thing to Do About Expiration, to
+Joshua Gerth, Joshua Chamas, Jonathan Roy (again), Mark D. Anderson,
+and Andrew Johnson for more suggestions about expiration, to Brent
+Powers for the Memoize::ExpireLRU module, to Ariel Scolnicov for
+delightful messages about the Fibonacci function, to Dion Almaer for
+thought-provoking suggestions about the default normalizer, to Walt
+Mankowski and Kurt Starsinic for much help investigating problems
+under threaded Perl, to Alex Dudkevich for reporting the bug in
+prototyped functions and for checking my patch, to Tony Bass for many
+helpful suggestions, to Jonathan Roy (again) for finding a use for
+C<unmemoize()>, to Philippe Verdret for enlightening discussion of
+C<Hook::PrePostCall>, to Nat Torkington for advice I ignored, to Chris
+Nandor for portability advice, to Randal Schwartz for suggesting the
+'C<flush_cache> function, and to Jenda Krynicky for being a light in
+the world.
+
+Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including
+this module in the core and for his patient and helpful guidance
+during the integration process.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/NEXT.pm b/Master/tlpkg/tlperl/lib/NEXT.pm
new file mode 100644
index 00000000000..1e59280241e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/NEXT.pm
@@ -0,0 +1,563 @@
+package NEXT;
+$VERSION = '0.64';
+use Carp;
+use strict;
+use overload ();
+
+sub NEXT::ELSEWHERE::ancestors
+{
+ my @inlist = shift;
+ my @outlist = ();
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
+ no strict 'refs';
+ unshift @inlist, @{"$outlist[-1]::ISA"};
+ }
+ return @outlist;
+}
+
+sub NEXT::ELSEWHERE::ordered_ancestors
+{
+ my @inlist = shift;
+ my @outlist = ();
+ while (my $next = shift @inlist) {
+ push @outlist, $next;
+ no strict 'refs';
+ push @inlist, @{"$outlist[-1]::ISA"};
+ }
+ return sort { $a->isa($b) ? -1
+ : $b->isa($a) ? +1
+ : 0 } @outlist;
+}
+
+sub NEXT::ELSEWHERE::buildAUTOLOAD
+{
+ my $autoload_name = caller() . '::AUTOLOAD';
+
+ no strict 'refs';
+ *{$autoload_name} = sub {
+ my ($self) = @_;
+ my $depth = 1;
+ until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
+ my $caller = (caller($depth))[3];
+ my $wanted = $NEXT::AUTOLOAD || $autoload_name;
+ undef $NEXT::AUTOLOAD;
+ my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g };
+ my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
+ croak "Can't call $wanted from $caller"
+ unless $caller_method eq $wanted_method;
+
+ my $key = ref $self && overload::Overloaded($self)
+ ? overload::StrVal($self) : $self;
+
+ local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
+ ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
+
+ unless ($NEXT::NEXT{$key,$wanted_method}) {
+ my @forebears =
+ NEXT::ELSEWHERE::ancestors ref $self || $self,
+ $wanted_class;
+ while (@forebears) {
+ last if shift @forebears eq $caller_class
+ }
+ no strict 'refs';
+ @{$NEXT::NEXT{$key,$wanted_method}} =
+ map {
+ my $stash = \%{"${_}::"};
+ ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
+ ? *{$stash->{$caller_method}}{CODE}
+ : () } @forebears
+ unless $wanted_method eq 'AUTOLOAD';
+ @{$NEXT::NEXT{$key,$wanted_method}} =
+ map {
+ my $stash = \%{"${_}::"};
+ ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
+ ? "${_}::AUTOLOAD"
+ : () } @forebears
+ unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
+ $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
+ }
+ my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
+ while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ }
+ && defined $call_method
+ && $NEXT::SEEN->{$key,$call_method}++) {
+ $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
+ }
+ unless (defined $call_method) {
+ return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ };
+ (local $Carp::CarpLevel)++;
+ croak qq(Can't locate object method "$wanted_method" ),
+ qq(via package "$caller_class");
+ };
+ return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
+ no strict 'refs';
+ do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// }
+ if $wanted_method eq 'AUTOLOAD';
+ $$call_method = $caller_class."::NEXT::".$wanted_method;
+ return $call_method->(@_);
+ };
+}
+
+no strict 'vars';
+package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
+
+package EVERY;
+
+sub EVERY::ELSEWHERE::buildAUTOLOAD {
+ my $autoload_name = caller() . '::AUTOLOAD';
+
+ no strict 'refs';
+ *{$autoload_name} = sub {
+ my ($self) = @_;
+ my $depth = 1;
+ until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
+ my $caller = (caller($depth))[3];
+ my $wanted = $EVERY::AUTOLOAD || $autoload_name;
+ undef $EVERY::AUTOLOAD;
+ my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
+
+ my $key = ref($self) && overload::Overloaded($self)
+ ? overload::StrVal($self) : $self;
+
+ local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
+ $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
+
+ return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
+
+ my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
+ $wanted_class;
+ @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ };
+ no strict 'refs';
+ my %seen;
+ my @every = map { my $sub = "${_}::$wanted_method";
+ !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
+ } @forebears
+ unless $wanted_method eq 'AUTOLOAD';
+
+ my $want = wantarray;
+ if (@every) {
+ if ($want) {
+ return map {($_, [$self->$_(@_[1..$#_])])} @every;
+ }
+ elsif (defined $want) {
+ return { map {($_, scalar($self->$_(@_[1..$#_])))}
+ @every
+ };
+ }
+ else {
+ $self->$_(@_[1..$#_]) for @every;
+ return;
+ }
+ }
+
+ @every = map { my $sub = "${_}::AUTOLOAD";
+ !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
+ } @forebears;
+ if ($want) {
+ return map { $$_ = ref($self)."::EVERY::".$wanted_method;
+ ($_, [$self->$_(@_[1..$#_])]);
+ } @every;
+ }
+ elsif (defined $want) {
+ return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
+ ($_, scalar($self->$_(@_[1..$#_])))
+ } @every
+ };
+ }
+ else {
+ for (@every) {
+ $$_ = ref($self)."::EVERY::".$wanted_method;
+ $self->$_(@_[1..$#_]);
+ }
+ return;
+ }
+ };
+}
+
+package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD();
+package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
+
+1;
+
+__END__
+
+=head1 NAME
+
+NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
+
+
+=head1 SYNOPSIS
+
+ use NEXT;
+
+ package A;
+ sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
+ sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package B;
+ use base qw( A );
+ sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package C;
+ sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
+ sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package D;
+ use base qw( B C );
+ sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
+ sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
+ sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
+
+ package main;
+
+ my $obj = bless {}, "D";
+
+ $obj->method(); # Calls D::method, A::method, C::method
+ $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
+
+ # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
+
+
+
+=head1 DESCRIPTION
+
+NEXT.pm adds a pseudoclass named C<NEXT> to any program
+that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
+C<m> is redispatched as if the calling method had not originally been found.
+
+In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
+left-to-right search of C<$self>'s class hierarchy that resulted in the
+original call to C<m>.
+
+Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
+begins a new dispatch that is restricted to searching the ancestors
+of the current class. C<$self-E<gt>NEXT::m()> can backtrack
+past the current class -- to look for a suitable method in other
+ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
+
+A typical use would be in the destructors of a class hierarchy,
+as illustrated in the synopsis above. Each class in the hierarchy
+has a DESTROY method that performs some class-specific action
+and then redispatches the call up the hierarchy. As a result,
+when an object of class D is destroyed, the destructors of I<all>
+its parent classes are called (in depth-first, left-to-right order).
+
+Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
+If such a method determined that it was not able to handle a
+particular call, it might choose to redispatch that call, in the
+hope that some other C<AUTOLOAD> (above it, or to its left) might
+do better.
+
+By default, if a redispatch attempt fails to find another method
+elsewhere in the objects class hierarchy, it quietly gives up and does
+nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
+is also unlike the (generally annoying) behaviour of C<SUPER>, which
+throws an exception if it cannot redispatch.
+
+Note that it is a fatal error for any method (including C<AUTOLOAD>)
+to attempt to redispatch any method that does not have the
+same name. For example:
+
+ sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
+
+
+=head2 Enforcing redispatch
+
+It is possible to make C<NEXT> redispatch more demandingly (i.e. like
+C<SUPER> does), so that the redispatch throws an exception if it cannot
+find a "next" method to call.
+
+To do this, simple invoke the redispatch as:
+
+ $self->NEXT::ACTUAL::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
+or it should throw an exception.
+
+C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
+decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
+semantics:
+
+ sub AUTOLOAD {
+ if ($AUTOLOAD =~ /foo|bar/) {
+ # handle here
+ }
+ else { # try elsewhere
+ shift()->NEXT::ACTUAL::AUTOLOAD(@_);
+ }
+ }
+
+By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
+method call, an exception will be thrown (as usually happens in the absence of
+a suitable C<AUTOLOAD>).
+
+
+=head2 Avoiding repetitions
+
+If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
+
+ # A B
+ # / \ /
+ # C D
+ # \ /
+ # E
+
+ use NEXT;
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::foo() }
+
+ E->foo();
+
+then derived classes may (re-)inherit base-class methods through two or
+more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
+through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
+will invoke the multiply inherited method as many times as it is
+inherited. For example, the above code prints:
+
+ called E::foo
+ called C::foo
+ called A::foo
+ called D::foo
+ called A::foo
+ called B::foo
+
+(i.e. C<A::foo> is called twice).
+
+In some cases this I<may> be the desired effect within a diamond hierarchy,
+but in others (e.g. for destructors) it may be more appropriate to
+call each method only once during a sequence of redispatches.
+
+To cover such cases, you can redispatch methods via:
+
+ $self->NEXT::DISTINCT::method();
+
+rather than:
+
+ $self->NEXT::method();
+
+This causes the redispatcher to only visit each distinct C<method> method
+once. That is, to skip any classes in the hierarchy that it has
+already visited during redispatch. So, for example, if the
+previous example were rewritten:
+
+ package A;
+ sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package B;
+ sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package C; @ISA = qw( A );
+ sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package D; @ISA = qw(A B);
+ sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ package E; @ISA = qw(C D);
+ sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
+
+ E->foo();
+
+then it would print:
+
+ called E::foo
+ called C::foo
+ called A::foo
+ called D::foo
+ called B::foo
+
+and omit the second call to C<A::foo> (since it would not be distinct
+from the first call to C<A::foo>).
+
+Note that you can also use:
+
+ $self->NEXT::DISTINCT::ACTUAL::method();
+
+or:
+
+ $self->NEXT::ACTUAL::DISTINCT::method();
+
+to get both unique invocation I<and> exception-on-failure.
+
+Note that, for historical compatibility, you can also use
+C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
+
+
+=head2 Invoking all versions of a method with a single call
+
+Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
+Its behaviour is considerably simpler than that of the C<NEXT> family.
+A call to:
+
+ $obj->EVERY::foo();
+
+calls I<every> method named C<foo> that the object in C<$obj> has inherited.
+That is:
+
+ use NEXT;
+
+ package A; @ISA = qw(B D X);
+ sub foo { print "A::foo " }
+
+ package B; @ISA = qw(D X);
+ sub foo { print "B::foo " }
+
+ package X; @ISA = qw(D);
+ sub foo { print "X::foo " }
+
+ package D;
+ sub foo { print "D::foo " }
+
+ package main;
+
+ my $obj = bless {}, 'A';
+ $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
+
+Prefixing a method call with C<EVERY::> causes every method in the
+object's hierarchy with that name to be invoked. As the above example
+illustrates, they are not called in Perl's usual "left-most-depth-first"
+order. Instead, they are called "breadth-first-dependency-wise".
+
+That means that the inheritance tree of the object is traversed breadth-first
+and the resulting order of classes is used as the sequence in which methods
+are called. However, that sequence is modified by imposing a rule that the
+appropriate method of a derived class must be called before the same method of
+any ancestral class. That's why, in the above example, C<X::foo> is called
+before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
+
+In general, there's no need to worry about the order of calls. They will be
+left-to-right, breadth-first, most-derived-first. This works perfectly for
+most inherited methods (including destructors), but is inappropriate for
+some kinds of methods (such as constructors, cloners, debuggers, and
+initializers) where it's more appropriate that the least-derived methods be
+called first (as more-derived methods may rely on the behaviour of their
+"ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
+
+ $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
+
+you can use the C<EVERY::LAST> pseudo-class:
+
+ $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
+
+which reverses the order of method call.
+
+Whichever version is used, the actual methods are called in the same
+context (list, scalar, or void) as the original call via C<EVERY>, and return:
+
+=over
+
+=item *
+
+A hash of array references in list context. Each entry of the hash has the
+fully qualified method name as its key and a reference to an array containing
+the method's list-context return values as its value.
+
+=item *
+
+A reference to a hash of scalar values in scalar context. Each entry of the hash has the
+fully qualified method name as its key and the method's scalar-context return values as its value.
+
+=item *
+
+Nothing in void context (obviously).
+
+=back
+
+=head2 Using C<EVERY> methods
+
+The typical way to use an C<EVERY> call is to wrap it in another base
+method, that all classes inherit. For example, to ensure that every
+destructor an object inherits is actually called (as opposed to just the
+left-most-depth-first-est one):
+
+ package Base;
+ sub DESTROY { $_[0]->EVERY::Destroy }
+
+ package Derived1;
+ use base 'Base';
+ sub Destroy {...}
+
+ package Derived2;
+ use base 'Base', 'Derived1';
+ sub Destroy {...}
+
+et cetera. Every derived class than needs its own clean-up
+behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
+which the call to C<EVERY::LAST::Destroy> in the inherited destructor
+then correctly picks up.
+
+Likewise, to create a class hierarchy in which every initializer inherited by
+a new object is invoked:
+
+ package Base;
+ sub new {
+ my ($class, %args) = @_;
+ my $obj = bless {}, $class;
+ $obj->EVERY::LAST::Init(\%args);
+ }
+
+ package Derived1;
+ use base 'Base';
+ sub Init {
+ my ($argsref) = @_;
+ ...
+ }
+
+ package Derived2;
+ use base 'Base', 'Derived1';
+ sub Init {
+ my ($argsref) = @_;
+ ...
+ }
+
+et cetera. Every derived class than needs some additional initialization
+behaviour simply adds its own C<Init> method (I<not> a C<new> method),
+which the call to C<EVERY::LAST::Init> in the inherited constructor
+then correctly picks up.
+
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org)
+
+=head1 BUGS AND IRRITATIONS
+
+Because it's a module, not an integral part of the interpreter, NEXT.pm
+has to guess where the surrounding call was found in the method
+look-up sequence. In the presence of diamond inheritance patterns
+it occasionally guesses wrong.
+
+It's also too slow (despite caching).
+
+Comment, suggestions, and patches welcome.
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl/lib/O.pm b/Master/tlpkg/tlperl/lib/O.pm
new file mode 100644
index 00000000000..2976a894208
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/O.pm
@@ -0,0 +1,143 @@
+package O;
+
+our $VERSION = '1.01';
+
+use B qw(minus_c save_BEGINs);
+use Carp;
+
+sub import {
+ my ($class, @options) = @_;
+ my ($quiet, $veryquiet) = (0, 0);
+ if ($options[0] eq '-q' || $options[0] eq '-qq') {
+ $quiet = 1;
+ open (SAVEOUT, ">&STDOUT");
+ close STDOUT;
+ open (STDOUT, ">", \$O::BEGIN_output);
+ if ($options[0] eq '-qq') {
+ $veryquiet = 1;
+ }
+ shift @options;
+ }
+ my $backend = shift (@options);
+ eval q[
+ BEGIN {
+ minus_c;
+ save_BEGINs;
+ }
+
+ CHECK {
+ if ($quiet) {
+ close STDOUT;
+ open (STDOUT, ">&SAVEOUT");
+ close SAVEOUT;
+ }
+
+ # Note: if you change the code after this 'use', please
+ # change the fudge factors in B::Concise (grep for
+ # "fragile kludge") so that its output still looks
+ # nice. Thanks. --smcc
+ use B::].$backend.q[ ();
+ if ($@) {
+ croak "use of backend $backend failed: $@";
+ }
+
+
+ my $compilesub = &{"B::${backend}::compile"}(@options);
+ if (ref($compilesub) ne "CODE") {
+ die $compilesub;
+ }
+
+ local $savebackslash = $\;
+ local ($\,$",$,) = (undef,' ','');
+ &$compilesub();
+
+ close STDERR if $veryquiet;
+ }
+ ];
+ die $@ if $@;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+O - Generic interface to Perl Compiler backends
+
+=head1 SYNOPSIS
+
+ perl -MO=[-q,]Backend[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This is the module that is used as a frontend to the Perl Compiler.
+
+If you pass the C<-q> option to the module, then the STDOUT
+filehandle will be redirected into the variable C<$O::BEGIN_output>
+during compilation. This has the effect that any output printed
+to STDOUT by BEGIN blocks or use'd modules will be stored in this
+variable rather than printed. It's useful with those backends which
+produce output themselves (C<Deparse>, C<Concise> etc), so that
+their output is not confused with that generated by the code
+being compiled.
+
+The C<-qq> option behaves like C<-q>, except that it also closes
+STDERR after deparsing has finished. This suppresses the "Syntax OK"
+message normally produced by perl.
+
+=head1 CONVENTIONS
+
+Most compiler backends use the following conventions: OPTIONS
+consists of a comma-separated list of words (no white-space).
+The C<-v> option usually puts the backend into verbose mode.
+The C<-ofile> option generates output to B<file> instead of
+stdout. The C<-D> option followed by various letters turns on
+various internal debugging flags. See the documentation for the
+desired backend (named C<B::Backend> for the example above) to
+find out about that backend.
+
+=head1 IMPLEMENTATION
+
+This section is only necessary for those who want to write a
+compiler backend module that can be used via this module.
+
+The command-line mentioned in the SYNOPSIS section corresponds to
+the Perl code
+
+ use O ("Backend", OPTIONS);
+
+The C<O::import> function loads the appropriate C<B::Backend> module
+and calls its C<compile> function, passing it OPTIONS. That function
+is expected to return a sub reference which we'll call CALLBACK. Next,
+the "compile-only" flag is switched on (equivalent to the command-line
+option C<-c>) and a CHECK block is registered which calls
+CALLBACK. Thus the main Perl program mentioned on the command-line is
+read in, parsed and compiled into internal syntax tree form. Since the
+C<-c> flag is set, the program does not start running (excepting BEGIN
+blocks of course) but the CALLBACK function registered by the compiler
+backend is called.
+
+In summary, a compiler backend module should be called "B::Foo"
+for some foo and live in the appropriate directory for that name.
+It should define a function called C<compile>. When the user types
+
+ perl -MO=Foo,OPTIONS foo.pl
+
+that function is called and is passed those OPTIONS (split on
+commas). It should return a sub ref to the main compilation function.
+After the user's program is loaded and parsed, that returned sub ref
+is invoked which can then go ahead and do the compilation, usually by
+making use of the C<B> module's functionality.
+
+=head1 BUGS
+
+The C<-q> and C<-qq> options don't work correctly if perl isn't
+compiled with PerlIO support : STDOUT will be closed instead of being
+redirected to C<$O::BEGIN_output>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Opcode.pm b/Master/tlpkg/tlperl/lib/Opcode.pm
new file mode 100644
index 00000000000..9dbbce0b5de
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Opcode.pm
@@ -0,0 +1,593 @@
+package Opcode;
+
+use 5.006_001;
+
+use strict;
+
+our($VERSION, @ISA, @EXPORT_OK);
+
+$VERSION = "1.15";
+
+use Carp;
+use Exporter ();
+use XSLoader ();
+
+BEGIN {
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(
+ opset ops_to_opset
+ opset_to_ops opset_to_hex invert_opset
+ empty_opset full_opset
+ opdesc opcodes opmask define_optag
+ opmask_add verify_opset opdump
+ );
+}
+
+sub opset (;@);
+sub opset_to_hex ($);
+sub opdump (;$);
+use subs @EXPORT_OK;
+
+XSLoader::load 'Opcode', $VERSION;
+
+_init_optags();
+
+sub ops_to_opset { opset @_ } # alias for old name
+
+sub opset_to_hex ($) {
+ return "(invalid opset)" unless verify_opset($_[0]);
+ unpack("h*",$_[0]);
+}
+
+sub opdump (;$) {
+ my $pat = shift;
+ # handy utility: perl -MOpcode=opdump -e 'opdump File'
+ foreach(opset_to_ops(full_opset)) {
+ my $op = sprintf " %12s %s\n", $_, opdesc($_);
+ next if defined $pat and $op !~ m/$pat/i;
+ print $op;
+ }
+}
+
+
+
+sub _init_optags {
+ my(%all, %seen);
+ @all{opset_to_ops(full_opset)} = (); # keys only
+
+ local($_);
+ local($/) = "\n=cut"; # skip to optags definition section
+ <DATA>;
+ $/ = "\n="; # now read in 'pod section' chunks
+ while(<DATA>) {
+ next unless m/^item\s+(:\w+)/;
+ my $tag = $1;
+
+ # Split into lines, keep only indented lines
+ my @lines = grep { m/^\s/ } split(/\n/);
+ foreach (@lines) { s/--.*// } # delete comments
+ my @ops = map { split ' ' } @lines; # get op words
+
+ foreach(@ops) {
+ warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_};
+ $seen{$_} = $tag;
+ delete $all{$_};
+ }
+ # opset will croak on invalid names
+ define_optag($tag, opset(@ops));
+ }
+ close(DATA);
+ warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all;
+}
+
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+Opcode - Disable named opcodes when compiling perl code
+
+=head1 SYNOPSIS
+
+ use Opcode;
+
+
+=head1 DESCRIPTION
+
+Perl code is always compiled into an internal format before execution.
+
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+The internal format is based on many distinct I<opcodes>.
+
+By default no opmask is in effect and any code can be compiled.
+
+The Opcode module allow you to define an I<operator mask> to be in
+effect when perl I<next> compiles any code. Attempting to compile code
+which contains a masked opcode will cause the compilation to fail
+with an error. The code will not be executed.
+
+=head1 NOTE
+
+The Opcode module is not usually used directly. See the ops pragma and
+Safe modules for more typical uses.
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head1 Operator Names and Operator Lists
+
+The canonical list of operator names is the contents of the array
+PL_op_name defined and initialised in file F<opcode.h> of the Perl
+source distribution (and installed into the perl library).
+
+Each operator has both a terse name (its opname) and a more verbose or
+recognisable descriptive name. The opdesc function can be used to
+return a list of descriptions for a list of operators.
+
+Many of the functions and methods listed below take a list of
+operators as parameters. Most operator lists can be made up of several
+types of element. Each element can be one of
+
+=over 8
+
+=item an operator name (opname)
+
+Operator names are typically small lowercase words like enterloop,
+leaveloop, last, next, redo etc. Sometimes they are rather cryptic
+like gv2cv, i_ncmp and ftsvtx.
+
+=item an operator tag name (optag)
+
+Operator tags can be used to refer to groups (or sets) of operators.
+Tag names always begin with a colon. The Opcode module defines several
+optags and the user can define others using the define_optag function.
+
+=item a negated opname or optag
+
+An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir.
+Negating an opname or optag means remove the corresponding ops from the
+accumulated set of ops at that point.
+
+=item an operator set (opset)
+
+An I<opset> as a binary string of approximately 44 bytes which holds a
+set or zero or more operators.
+
+The opset and opset_to_ops functions can be used to convert from
+a list of operators to an opset and I<vice versa>.
+
+Wherever a list of operators can be given you can use one or more opsets.
+See also Manipulating Opsets below.
+
+=back
+
+
+=head1 Opcode Functions
+
+The Opcode package contains functions for manipulating operator names
+tags and sets. All are available for export by the package.
+
+=over 8
+
+=item opcodes
+
+In a scalar context opcodes returns the number of opcodes in this
+version of perl (around 350 for perl-5.7.0).
+
+In a list context it returns a list of all the operator names.
+(Not yet implemented, use @names = opset_to_ops(full_opset).)
+
+=item opset (OP, ...)
+
+Returns an opset containing the listed operators.
+
+=item opset_to_ops (OPSET)
+
+Returns a list of operator names corresponding to those operators in
+the set.
+
+=item opset_to_hex (OPSET)
+
+Returns a string representation of an opset. Can be handy for debugging.
+
+=item full_opset
+
+Returns an opset which includes all operators.
+
+=item empty_opset
+
+Returns an opset which contains no operators.
+
+=item invert_opset (OPSET)
+
+Returns an opset which is the inverse set of the one supplied.
+
+=item verify_opset (OPSET, ...)
+
+Returns true if the supplied opset looks like a valid opset (is the
+right length etc) otherwise it returns false. If an optional second
+parameter is true then verify_opset will croak on an invalid opset
+instead of returning false.
+
+Most of the other Opcode functions call verify_opset automatically
+and will croak if given an invalid opset.
+
+=item define_optag (OPTAG, OPSET)
+
+Define OPTAG as a symbolic name for OPSET. Optag names always start
+with a colon C<:>.
+
+The optag name used must not be defined already (define_optag will
+croak if it is already defined). Optag names are global to the perl
+process and optag definitions cannot be altered or deleted once
+defined.
+
+It is strongly recommended that applications using Opcode should use a
+leading capital letter on their tag names since lowercase names are
+reserved for use by the Opcode module. If using Opcode within a module
+you should prefix your tags names with the name of your module to
+ensure uniqueness and thus avoid clashes with other modules.
+
+=item opmask_add (OPSET)
+
+Adds the supplied opset to the current opmask. Note that there is
+currently I<no> mechanism for unmasking ops once they have been masked.
+This is intentional.
+
+=item opmask
+
+Returns an opset corresponding to the current opmask.
+
+=item opdesc (OP, ...)
+
+This takes a list of operator names and returns the corresponding list
+of operator descriptions.
+
+=item opdump (PAT)
+
+Dumps to STDOUT a two column list of op names and op descriptions.
+If an optional pattern is given then only lines which match the
+(case insensitive) pattern will be output.
+
+It's designed to be used as a handy command line utility:
+
+ perl -MOpcode=opdump -e opdump
+ perl -MOpcode=opdump -e 'opdump Eval'
+
+=back
+
+=head1 Manipulating Opsets
+
+Opsets may be manipulated using the perl bit vector operators & (and), | (or),
+^ (xor) and ~ (negate/invert).
+
+However you should never rely on the numerical position of any opcode
+within the opset. In other words both sides of a bit vector operator
+should be opsets returned from Opcode functions.
+
+Also, since the number of opcodes in your current version of perl might
+not be an exact multiple of eight, there may be unused bits in the last
+byte of an upset. This should not cause any problems (Opcode functions
+ignore those extra bits) but it does mean that using the ~ operator
+will typically not produce the same 'physical' opset 'string' as the
+invert_opset function.
+
+
+=head1 TO DO (maybe)
+
+ $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv
+
+ $yes = opset_can($opset, @ops) true if $opset has all @ops set
+
+ @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...)
+
+=cut
+
+# the =cut above is used by _init_optags() to get here quickly
+
+=head1 Predefined Opcode Tags
+
+=over 5
+
+=item :base_core
+
+ null stub scalar pushmark wantarray const defined undef
+
+ rv2sv sassign
+
+ rv2av aassign aelem aelemfast aslice av2arylen
+
+ rv2hv helem hslice each values keys exists delete aeach akeys avalues
+ boolkeys
+
+ preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
+ int hex oct abs pow multiply i_multiply divide i_divide
+ modulo i_modulo add i_add subtract i_subtract
+
+ left_shift right_shift bit_and bit_xor bit_or negate i_negate
+ not complement
+
+ lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp
+ slt sgt sle sge seq sne scmp
+
+ substr vec stringify study pos length index rindex ord chr
+
+ ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp
+
+ match split qr
+
+ list lslice splice push pop shift unshift reverse
+
+ cond_expr flip flop andassign orassign dorassign and or dor xor
+
+ warn die lineseq nextstate scope enter leave
+
+ rv2cv anoncode prototype
+
+ entersub leavesub leavesublv return method method_named -- XXX loops via recursion?
+
+ leaveeval -- needed for Safe to operate, is safe without entereval
+
+=item :base_mem
+
+These memory related ops are not included in :base_core because they
+can easily be used to implement a resource attack (e.g., consume all
+available memory).
+
+ concat repeat join range
+
+ anonlist anonhash
+
+Note that despite the existence of this optag a memory resource attack
+may still be possible using only :base_core ops.
+
+Disabling these ops is a I<very> heavy handed way to attempt to prevent
+a memory resource attack. It's probable that a specific memory limit
+mechanism will be added to perl in the near future.
+
+=item :base_loop
+
+These loop ops are not included in :base_core because they can easily be
+used to implement a resource attack (e.g., consume all available CPU time).
+
+ grepstart grepwhile
+ mapstart mapwhile
+ enteriter iter
+ enterloop leaveloop unstack
+ last next redo
+ goto
+
+=item :base_io
+
+These ops enable I<filehandle> (rather than filename) based input and
+output. These are safe on the assumption that only pre-existing
+filehandles are available for use. Usually, to create new filehandles
+other ops such as open would need to be enabled, if you don't take into
+account the magical open of ARGV.
+
+ readline rcatline getc read
+
+ formline enterwrite leavewrite
+
+ print say sysread syswrite send recv
+
+ eof tell seek sysseek
+
+ readdir telldir seekdir rewinddir
+
+=item :base_orig
+
+These are a hotchpotch of opcodes still waiting to be considered
+
+ gvsv gv gelem
+
+ padsv padav padhv padany
+
+ once
+
+ rv2gv refgen srefgen ref
+
+ bless -- could be used to change ownership of objects (reblessing)
+
+ pushre regcmaybe regcreset regcomp subst substcont
+
+ sprintf prtf -- can core dump
+
+ crypt
+
+ tie untie
+
+ dbmopen dbmclose
+ sselect select
+ pipe_op sockpair
+
+ getppid getpgrp setpgrp getpriority setpriority localtime gmtime
+
+ entertry leavetry -- can be used to 'hide' fatal errors
+
+ entergiven leavegiven
+ enterwhen leavewhen
+ break continue
+ smartmatch
+
+ custom -- where should this go
+
+=item :base_math
+
+These ops are not included in :base_core because of the risk of them being
+used to generate floating point exceptions (which would have to be caught
+using a $SIG{FPE} handler).
+
+ atan2 sin cos exp log sqrt
+
+These ops are not included in :base_core because they have an effect
+beyond the scope of the compartment.
+
+ rand srand
+
+=item :base_thread
+
+These ops are related to multi-threading.
+
+ lock
+
+=item :default
+
+A handy tag name for a I<reasonable> default set of ops. (The current ops
+allowed are unstable while development continues. It will change.)
+
+ :base_core :base_mem :base_loop :base_orig :base_thread
+
+This list used to contain :base_io prior to Opcode 1.07.
+
+If safety matters to you (and why else would you be using the Opcode module?)
+then you should not rely on the definition of this, or indeed any other, optag!
+
+=item :filesys_read
+
+ stat lstat readlink
+
+ ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread
+ ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned
+ ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx
+
+ fttext ftbinary
+
+ fileno
+
+=item :sys_db
+
+ ghbyname ghbyaddr ghostent shostent ehostent -- hosts
+ gnbyname gnbyaddr gnetent snetent enetent -- networks
+ gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols
+ gsbyname gsbyport gservent sservent eservent -- services
+
+ gpwnam gpwuid gpwent spwent epwent getlogin -- users
+ ggrnam ggrgid ggrent sgrent egrent -- groups
+
+=item :browse
+
+A handy tag name for a I<reasonable> default set of ops beyond the
+:default optag. Like :default (and indeed all the other optags) its
+current definition is unstable while development continues. It will change.
+
+The :browse tag represents the next step beyond :default. It it a
+superset of the :default ops and adds :filesys_read the :sys_db.
+The intent being that scripts can access more (possibly sensitive)
+information about your system but not be able to change it.
+
+ :default :filesys_read :sys_db
+
+=item :filesys_open
+
+ sysopen open close
+ umask binmode
+
+ open_dir closedir -- other dir ops are in :base_io
+
+=item :filesys_write
+
+ link unlink rename symlink truncate
+
+ mkdir rmdir
+
+ utime chmod chown
+
+ fcntl -- not strictly filesys related, but possibly as dangerous?
+
+=item :subprocess
+
+ backtick system
+
+ fork
+
+ wait waitpid
+
+ glob -- access to Cshell via <`rm *`>
+
+=item :ownprocess
+
+ exec exit kill
+
+ time tms -- could be used for timing attacks (paranoid?)
+
+=item :others
+
+This tag holds groups of assorted specialist opcodes that don't warrant
+having optags defined for them.
+
+SystemV Interprocess Communications:
+
+ msgctl msgget msgrcv msgsnd
+
+ semctl semget semop
+
+ shmctl shmget shmread shmwrite
+
+=item :load
+
+This tag holds opcodes related to loading modules and getting information
+about calling environment and args.
+
+ require dofile
+ caller
+
+=item :still_to_be_decided
+
+ chdir
+ flock ioctl
+
+ socket getpeername ssockopt
+ bind connect listen accept shutdown gsockopt getsockname
+
+ sleep alarm -- changes global timer state and signal handling
+ sort -- assorted problems including core dumps
+ tied -- can be used to access object implementing a tie
+ pack unpack -- can be used to create/use memory pointers
+
+ hintseval -- constant op holding eval hints
+
+ entereval -- can be used to hide code from initial compile
+
+ reset
+
+ dbstate -- perl -d version of nextstate(ment) opcode
+
+=item :dangerous
+
+This tag is simply a bucket for opcodes that are unlikely to be used via
+a tag name but need to be tagged for completeness and documentation.
+
+ syscall dump chroot
+
+=back
+
+=head1 SEE ALSO
+
+L<ops> -- perl pragma interface to Opcode module.
+
+L<Safe> -- Opcode and namespace limited execution compartments
+
+=head1 AUTHORS
+
+Originally designed and implemented by Malcolm Beattie,
+mbeattie@sable.ox.ac.uk as part of Safe version 1.
+
+Split out from Safe module version 1, named opcode tags and other
+changes added by Tim Bunce.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/POSIX.pm b/Master/tlpkg/tlperl/lib/POSIX.pm
new file mode 100644
index 00000000000..ffbd9de0a29
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/POSIX.pm
@@ -0,0 +1,1042 @@
+package POSIX;
+use strict;
+use warnings;
+
+our(@ISA, %EXPORT_TAGS, @EXPORT_OK, @EXPORT, $AUTOLOAD, %SIGRT) = ();
+
+our $VERSION = "1.19";
+
+use AutoLoader;
+
+use XSLoader ();
+
+use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
+ F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND
+ O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
+ O_WRONLY SEEK_CUR SEEK_END SEEK_SET
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID
+ S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR);
+
+# Grandfather old foo_h form to new :foo_h form
+my $loaded;
+
+sub import {
+ load_imports() unless $loaded++;
+ my $this = shift;
+ my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_;
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($this,@list);
+}
+
+sub croak { require Carp; goto &Carp::croak }
+# declare usage to assist AutoLoad
+sub usage;
+
+XSLoader::load 'POSIX', $VERSION;
+
+sub AUTOLOAD {
+ no strict;
+ no warnings 'uninitialized';
+ if ($AUTOLOAD =~ /::(_?[a-z])/) {
+ # require AutoLoader;
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD
+ }
+ local $! = 0;
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ my ($error, $val) = constant($constname);
+ croak $error if $error;
+ *$AUTOLOAD = sub { $val };
+
+ goto &$AUTOLOAD;
+}
+
+package POSIX::SigAction;
+
+use AutoLoader 'AUTOLOAD';
+
+package POSIX::SigRt;
+
+use AutoLoader 'AUTOLOAD';
+
+use Tie::Hash;
+
+use vars qw($SIGACTION_FLAGS $_SIGRTMIN $_SIGRTMAX $_sigrtn @ISA);
+@POSIX::SigRt::ISA = qw(Tie::StdHash);
+
+$SIGACTION_FLAGS = 0;
+
+tie %POSIX::SIGRT, 'POSIX::SigRt';
+
+sub DESTROY {};
+
+package POSIX;
+
+1;
+__END__
+
+sub usage {
+ my ($mess) = @_;
+ croak "Usage: POSIX::$mess";
+}
+
+sub redef {
+ my ($mess) = @_;
+ croak "Use method $mess instead";
+}
+
+sub unimpl {
+ my ($mess) = @_;
+ $mess =~ s/xxx//;
+ croak "Unimplemented: POSIX::$mess";
+}
+
+sub assert {
+ usage "assert(expr)" if @_ != 1;
+ if (!$_[0]) {
+ croak "Assertion failed";
+ }
+}
+
+sub tolower {
+ usage "tolower(string)" if @_ != 1;
+ lc($_[0]);
+}
+
+sub toupper {
+ usage "toupper(string)" if @_ != 1;
+ uc($_[0]);
+}
+
+sub closedir {
+ usage "closedir(dirhandle)" if @_ != 1;
+ CORE::closedir($_[0]);
+}
+
+sub opendir {
+ usage "opendir(directory)" if @_ != 1;
+ my $dirhandle;
+ CORE::opendir($dirhandle, $_[0])
+ ? $dirhandle
+ : undef;
+}
+
+sub readdir {
+ usage "readdir(dirhandle)" if @_ != 1;
+ CORE::readdir($_[0]);
+}
+
+sub rewinddir {
+ usage "rewinddir(dirhandle)" if @_ != 1;
+ CORE::rewinddir($_[0]);
+}
+
+sub errno {
+ usage "errno()" if @_ != 0;
+ $! + 0;
+}
+
+sub creat {
+ usage "creat(filename, mode)" if @_ != 2;
+ &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]);
+}
+
+sub fcntl {
+ usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
+ CORE::fcntl($_[0], $_[1], $_[2]);
+}
+
+sub getgrgid {
+ usage "getgrgid(gid)" if @_ != 1;
+ CORE::getgrgid($_[0]);
+}
+
+sub getgrnam {
+ usage "getgrnam(name)" if @_ != 1;
+ CORE::getgrnam($_[0]);
+}
+
+sub atan2 {
+ usage "atan2(x,y)" if @_ != 2;
+ CORE::atan2($_[0], $_[1]);
+}
+
+sub cos {
+ usage "cos(x)" if @_ != 1;
+ CORE::cos($_[0]);
+}
+
+sub exp {
+ usage "exp(x)" if @_ != 1;
+ CORE::exp($_[0]);
+}
+
+sub fabs {
+ usage "fabs(x)" if @_ != 1;
+ CORE::abs($_[0]);
+}
+
+sub log {
+ usage "log(x)" if @_ != 1;
+ CORE::log($_[0]);
+}
+
+sub pow {
+ usage "pow(x,exponent)" if @_ != 2;
+ $_[0] ** $_[1];
+}
+
+sub sin {
+ usage "sin(x)" if @_ != 1;
+ CORE::sin($_[0]);
+}
+
+sub sqrt {
+ usage "sqrt(x)" if @_ != 1;
+ CORE::sqrt($_[0]);
+}
+
+sub getpwnam {
+ usage "getpwnam(name)" if @_ != 1;
+ CORE::getpwnam($_[0]);
+}
+
+sub getpwuid {
+ usage "getpwuid(uid)" if @_ != 1;
+ CORE::getpwuid($_[0]);
+}
+
+sub longjmp {
+ unimpl "longjmp() is C-specific: use die instead";
+}
+
+sub setjmp {
+ unimpl "setjmp() is C-specific: use eval {} instead";
+}
+
+sub siglongjmp {
+ unimpl "siglongjmp() is C-specific: use die instead";
+}
+
+sub sigsetjmp {
+ unimpl "sigsetjmp() is C-specific: use eval {} instead";
+}
+
+sub kill {
+ usage "kill(pid, sig)" if @_ != 2;
+ CORE::kill $_[1], $_[0];
+}
+
+sub raise {
+ usage "raise(sig)" if @_ != 1;
+ CORE::kill $_[0], $$; # Is this good enough?
+}
+
+sub offsetof {
+ unimpl "offsetof() is C-specific, stopped";
+}
+
+sub clearerr {
+ redef "IO::Handle::clearerr()";
+}
+
+sub fclose {
+ redef "IO::Handle::close()";
+}
+
+sub fdopen {
+ redef "IO::Handle::new_from_fd()";
+}
+
+sub feof {
+ redef "IO::Handle::eof()";
+}
+
+sub fgetc {
+ redef "IO::Handle::getc()";
+}
+
+sub fgets {
+ redef "IO::Handle::gets()";
+}
+
+sub fileno {
+ redef "IO::Handle::fileno()";
+}
+
+sub fopen {
+ redef "IO::File::open()";
+}
+
+sub fprintf {
+ unimpl "fprintf() is C-specific--use printf instead";
+}
+
+sub fputc {
+ unimpl "fputc() is C-specific--use print instead";
+}
+
+sub fputs {
+ unimpl "fputs() is C-specific--use print instead";
+}
+
+sub fread {
+ unimpl "fread() is C-specific--use read instead";
+}
+
+sub freopen {
+ unimpl "freopen() is C-specific--use open instead";
+}
+
+sub fscanf {
+ unimpl "fscanf() is C-specific--use <> and regular expressions instead";
+}
+
+sub fseek {
+ redef "IO::Seekable::seek()";
+}
+
+sub fsync {
+ redef "IO::Handle::sync()";
+}
+
+sub ferror {
+ redef "IO::Handle::error()";
+}
+
+sub fflush {
+ redef "IO::Handle::flush()";
+}
+
+sub fgetpos {
+ redef "IO::Seekable::getpos()";
+}
+
+sub fsetpos {
+ redef "IO::Seekable::setpos()";
+}
+
+sub ftell {
+ redef "IO::Seekable::tell()";
+}
+
+sub fwrite {
+ unimpl "fwrite() is C-specific--use print instead";
+}
+
+sub getc {
+ usage "getc(handle)" if @_ != 1;
+ CORE::getc($_[0]);
+}
+
+sub getchar {
+ usage "getchar()" if @_ != 0;
+ CORE::getc(STDIN);
+}
+
+sub gets {
+ usage "gets()" if @_ != 0;
+ scalar <STDIN>;
+}
+
+sub perror {
+ print STDERR "@_: " if @_;
+ print STDERR $!,"\n";
+}
+
+sub printf {
+ usage "printf(pattern, args...)" if @_ < 1;
+ CORE::printf STDOUT @_;
+}
+
+sub putc {
+ unimpl "putc() is C-specific--use print instead";
+}
+
+sub putchar {
+ unimpl "putchar() is C-specific--use print instead";
+}
+
+sub puts {
+ unimpl "puts() is C-specific--use print instead";
+}
+
+sub remove {
+ usage "remove(filename)" if @_ != 1;
+ (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0]);
+}
+
+sub rename {
+ usage "rename(oldfilename, newfilename)" if @_ != 2;
+ CORE::rename($_[0], $_[1]);
+}
+
+sub rewind {
+ usage "rewind(filehandle)" if @_ != 1;
+ CORE::seek($_[0],0,0);
+}
+
+sub scanf {
+ unimpl "scanf() is C-specific--use <> and regular expressions instead";
+}
+
+sub sprintf {
+ usage "sprintf(pattern,args)" if @_ == 0;
+ CORE::sprintf(shift,@_);
+}
+
+sub sscanf {
+ unimpl "sscanf() is C-specific--use regular expressions instead";
+}
+
+sub tmpfile {
+ redef "IO::File::new_tmpfile()";
+}
+
+sub ungetc {
+ redef "IO::Handle::ungetc()";
+}
+
+sub vfprintf {
+ unimpl "vfprintf() is C-specific";
+}
+
+sub vprintf {
+ unimpl "vprintf() is C-specific";
+}
+
+sub vsprintf {
+ unimpl "vsprintf() is C-specific";
+}
+
+sub abs {
+ usage "abs(x)" if @_ != 1;
+ CORE::abs($_[0]);
+}
+
+sub atexit {
+ unimpl "atexit() is C-specific: use END {} instead";
+}
+
+sub atof {
+ unimpl "atof() is C-specific, stopped";
+}
+
+sub atoi {
+ unimpl "atoi() is C-specific, stopped";
+}
+
+sub atol {
+ unimpl "atol() is C-specific, stopped";
+}
+
+sub bsearch {
+ unimpl "bsearch() not supplied";
+}
+
+sub calloc {
+ unimpl "calloc() is C-specific, stopped";
+}
+
+sub div {
+ unimpl "div() is C-specific, use /, % and int instead";
+}
+
+sub exit {
+ usage "exit(status)" if @_ != 1;
+ CORE::exit($_[0]);
+}
+
+sub free {
+ unimpl "free() is C-specific, stopped";
+}
+
+sub getenv {
+ usage "getenv(name)" if @_ != 1;
+ $ENV{$_[0]};
+}
+
+sub labs {
+ unimpl "labs() is C-specific, use abs instead";
+}
+
+sub ldiv {
+ unimpl "ldiv() is C-specific, use /, % and int instead";
+}
+
+sub malloc {
+ unimpl "malloc() is C-specific, stopped";
+}
+
+sub qsort {
+ unimpl "qsort() is C-specific, use sort instead";
+}
+
+sub rand {
+ unimpl "rand() is non-portable, use Perl's rand instead";
+}
+
+sub realloc {
+ unimpl "realloc() is C-specific, stopped";
+}
+
+sub srand {
+ unimpl "srand()";
+}
+
+sub system {
+ usage "system(command)" if @_ != 1;
+ CORE::system($_[0]);
+}
+
+sub memchr {
+ unimpl "memchr() is C-specific, use index() instead";
+}
+
+sub memcmp {
+ unimpl "memcmp() is C-specific, use eq instead";
+}
+
+sub memcpy {
+ unimpl "memcpy() is C-specific, use = instead";
+}
+
+sub memmove {
+ unimpl "memmove() is C-specific, use = instead";
+}
+
+sub memset {
+ unimpl "memset() is C-specific, use x instead";
+}
+
+sub strcat {
+ unimpl "strcat() is C-specific, use .= instead";
+}
+
+sub strchr {
+ unimpl "strchr() is C-specific, use index() instead";
+}
+
+sub strcmp {
+ unimpl "strcmp() is C-specific, use eq instead";
+}
+
+sub strcpy {
+ unimpl "strcpy() is C-specific, use = instead";
+}
+
+sub strcspn {
+ unimpl "strcspn() is C-specific, use regular expressions instead";
+}
+
+sub strerror {
+ usage "strerror(errno)" if @_ != 1;
+ local $! = $_[0];
+ $! . "";
+}
+
+sub strlen {
+ unimpl "strlen() is C-specific, use length instead";
+}
+
+sub strncat {
+ unimpl "strncat() is C-specific, use .= instead";
+}
+
+sub strncmp {
+ unimpl "strncmp() is C-specific, use eq instead";
+}
+
+sub strncpy {
+ unimpl "strncpy() is C-specific, use = instead";
+}
+
+sub strpbrk {
+ unimpl "strpbrk() is C-specific, stopped";
+}
+
+sub strrchr {
+ unimpl "strrchr() is C-specific, use rindex() instead";
+}
+
+sub strspn {
+ unimpl "strspn() is C-specific, stopped";
+}
+
+sub strstr {
+ usage "strstr(big, little)" if @_ != 2;
+ CORE::index($_[0], $_[1]);
+}
+
+sub strtok {
+ unimpl "strtok() is C-specific, stopped";
+}
+
+sub chmod {
+ usage "chmod(mode, filename)" if @_ != 2;
+ CORE::chmod($_[0], $_[1]);
+}
+
+sub fstat {
+ usage "fstat(fd)" if @_ != 1;
+ local *TMP;
+ CORE::open(TMP, "<&$_[0]"); # Gross.
+ my @l = CORE::stat(TMP);
+ CORE::close(TMP);
+ @l;
+}
+
+sub mkdir {
+ usage "mkdir(directoryname, mode)" if @_ != 2;
+ CORE::mkdir($_[0], $_[1]);
+}
+
+sub stat {
+ usage "stat(filename)" if @_ != 1;
+ CORE::stat($_[0]);
+}
+
+sub umask {
+ usage "umask(mask)" if @_ != 1;
+ CORE::umask($_[0]);
+}
+
+sub wait {
+ usage "wait()" if @_ != 0;
+ CORE::wait();
+}
+
+sub waitpid {
+ usage "waitpid(pid, options)" if @_ != 2;
+ CORE::waitpid($_[0], $_[1]);
+}
+
+sub gmtime {
+ usage "gmtime(time)" if @_ != 1;
+ CORE::gmtime($_[0]);
+}
+
+sub localtime {
+ usage "localtime(time)" if @_ != 1;
+ CORE::localtime($_[0]);
+}
+
+sub time {
+ usage "time()" if @_ != 0;
+ CORE::time;
+}
+
+sub alarm {
+ usage "alarm(seconds)" if @_ != 1;
+ CORE::alarm($_[0]);
+}
+
+sub chdir {
+ usage "chdir(directory)" if @_ != 1;
+ CORE::chdir($_[0]);
+}
+
+sub chown {
+ usage "chown(uid, gid, filename)" if @_ != 3;
+ CORE::chown($_[0], $_[1], $_[2]);
+}
+
+sub execl {
+ unimpl "execl() is C-specific, stopped";
+}
+
+sub execle {
+ unimpl "execle() is C-specific, stopped";
+}
+
+sub execlp {
+ unimpl "execlp() is C-specific, stopped";
+}
+
+sub execv {
+ unimpl "execv() is C-specific, stopped";
+}
+
+sub execve {
+ unimpl "execve() is C-specific, stopped";
+}
+
+sub execvp {
+ unimpl "execvp() is C-specific, stopped";
+}
+
+sub fork {
+ usage "fork()" if @_ != 0;
+ CORE::fork;
+}
+
+sub getegid {
+ usage "getegid()" if @_ != 0;
+ $) + 0;
+}
+
+sub geteuid {
+ usage "geteuid()" if @_ != 0;
+ $> + 0;
+}
+
+sub getgid {
+ usage "getgid()" if @_ != 0;
+ $( + 0;
+}
+
+sub getgroups {
+ usage "getgroups()" if @_ != 0;
+ my %seen;
+ grep(!$seen{$_}++, split(' ', $) ));
+}
+
+sub getlogin {
+ usage "getlogin()" if @_ != 0;
+ CORE::getlogin();
+}
+
+sub getpgrp {
+ usage "getpgrp()" if @_ != 0;
+ CORE::getpgrp;
+}
+
+sub getpid {
+ usage "getpid()" if @_ != 0;
+ $$;
+}
+
+sub getppid {
+ usage "getppid()" if @_ != 0;
+ CORE::getppid;
+}
+
+sub getuid {
+ usage "getuid()" if @_ != 0;
+ $<;
+}
+
+sub isatty {
+ usage "isatty(filehandle)" if @_ != 1;
+ -t $_[0];
+}
+
+sub link {
+ usage "link(oldfilename, newfilename)" if @_ != 2;
+ CORE::link($_[0], $_[1]);
+}
+
+sub rmdir {
+ usage "rmdir(directoryname)" if @_ != 1;
+ CORE::rmdir($_[0]);
+}
+
+sub setbuf {
+ redef "IO::Handle::setbuf()";
+}
+
+sub setvbuf {
+ redef "IO::Handle::setvbuf()";
+}
+
+sub sleep {
+ usage "sleep(seconds)" if @_ != 1;
+ $_[0] - CORE::sleep($_[0]);
+}
+
+sub unlink {
+ usage "unlink(filename)" if @_ != 1;
+ CORE::unlink($_[0]);
+}
+
+sub utime {
+ usage "utime(filename, atime, mtime)" if @_ != 3;
+ CORE::utime($_[1], $_[2], $_[0]);
+}
+
+sub load_imports {
+%EXPORT_TAGS = (
+
+ assert_h => [qw(assert NDEBUG)],
+
+ ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower
+ isprint ispunct isspace isupper isxdigit tolower toupper)],
+
+ dirent_h => [],
+
+ errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
+ EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
+ ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
+ EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
+ EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
+ EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
+ ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
+ ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
+ EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
+ ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
+ ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
+ EUSERS EWOULDBLOCK EXDEV errno)],
+
+ fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
+ F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
+ O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
+ O_RDONLY O_RDWR O_TRUNC O_WRONLY
+ creat
+ SEEK_CUR SEEK_END SEEK_SET
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
+ S_IWGRP S_IWOTH S_IWUSR)],
+
+ float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
+ DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
+ DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
+ FLT_DIG FLT_EPSILON FLT_MANT_DIG
+ FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP
+ FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP
+ FLT_RADIX FLT_ROUNDS
+ LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
+ LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
+ LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
+
+ grp_h => [],
+
+ limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
+ INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
+ MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
+ PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
+ SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX
+ ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX
+ _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
+ _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
+ _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
+ _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
+
+ locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES
+ LC_MONETARY LC_NUMERIC LC_TIME NULL
+ localeconv setlocale)],
+
+ math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
+ frexp ldexp log10 modf pow sinh tan tanh)],
+
+ pwd_h => [],
+
+ setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
+
+ signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK
+ SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM
+ SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL
+ SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP
+ SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2
+ SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK
+ raise sigaction signal sigpending sigprocmask sigsuspend)],
+
+ stdarg_h => [],
+
+ stddef_h => [qw(NULL offsetof)],
+
+ stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
+ L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET
+ STREAM_MAX TMP_MAX stderr stdin stdout
+ clearerr fclose fdopen feof ferror fflush fgetc fgetpos
+ fgets fopen fprintf fputc fputs fread freopen
+ fscanf fseek fsetpos ftell fwrite getchar gets
+ perror putc putchar puts remove rewind
+ scanf setbuf setvbuf sscanf tmpfile tmpnam
+ ungetc vfprintf vprintf vsprintf)],
+
+ stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
+ abort atexit atof atoi atol bsearch calloc div
+ free getenv labs ldiv malloc mblen mbstowcs mbtowc
+ qsort realloc strtod strtol strtoul wcstombs wctomb)],
+
+ string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
+ strchr strcmp strcoll strcpy strcspn strerror strlen
+ strncat strncmp strncpy strpbrk strrchr strspn strstr
+ strtok strxfrm)],
+
+ sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
+ S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
+ fstat mkfifo)],
+
+ sys_times_h => [],
+
+ sys_types_h => [],
+
+ sys_utsname_h => [qw(uname)],
+
+ sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
+ WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
+
+ termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
+ B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
+ CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
+ ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
+ INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST
+ PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION
+ TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW
+ TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
+ VSTOP VSUSP VTIME
+ cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
+ tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
+
+ time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
+ difftime mktime strftime tzset tzname)],
+
+ unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
+ STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
+ _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
+ _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
+ _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED
+ _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS
+ _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX
+ _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL
+ _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS
+ _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
+ _exit access ctermid cuserid
+ dup2 dup execl execle execlp execv execve execvp
+ fpathconf fsync getcwd getegid geteuid getgid getgroups
+ getpid getuid isatty lseek pathconf pause setgid setpgid
+ setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
+
+ utime_h => [],
+
+);
+
+# Exporter::export_tags();
+{
+ # De-duplicate the export list:
+ my %export;
+ @export{map {@$_} values %EXPORT_TAGS} = ();
+ # Doing the de-dup with a temporary hash has the advantage that the SVs in
+ # @EXPORT are actually shared hash key sacalars, which will save some memory.
+ push @EXPORT, keys %export;
+}
+
+@EXPORT_OK = qw(
+ abs
+ alarm
+ atan2
+ chdir
+ chmod
+ chown
+ close
+ closedir
+ cos
+ exit
+ exp
+ fcntl
+ fileno
+ fork
+ getc
+ getgrgid
+ getgrnam
+ getlogin
+ getpgrp
+ getppid
+ getpwnam
+ getpwuid
+ gmtime
+ isatty
+ kill
+ lchown
+ link
+ localtime
+ log
+ mkdir
+ nice
+ open
+ opendir
+ pipe
+ printf
+ rand
+ read
+ readdir
+ rename
+ rewinddir
+ rmdir
+ sin
+ sleep
+ sprintf
+ sqrt
+ srand
+ stat
+ system
+ time
+ times
+ umask
+ unlink
+ utime
+ wait
+ waitpid
+ write
+);
+
+require Exporter;
+}
+
+package POSIX::SigAction;
+
+sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
+sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
+sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} };
+sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
+sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
+
+package POSIX::SigRt;
+
+
+sub _init {
+ $_SIGRTMIN = &POSIX::SIGRTMIN;
+ $_SIGRTMAX = &POSIX::SIGRTMAX;
+ $_sigrtn = $_SIGRTMAX - $_SIGRTMIN;
+}
+
+sub _croak {
+ &_init unless defined $_sigrtn;
+ die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0;
+}
+
+sub _getsig {
+ &_croak;
+ my $rtsig = $_[0];
+ # Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C.
+ $rtsig = $_SIGRTMIN + ($1 || 0)
+ if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/;
+ return $rtsig;
+}
+
+sub _exist {
+ my $rtsig = _getsig($_[1]);
+ my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX;
+ ($rtsig, $ok);
+}
+
+sub _check {
+ my ($rtsig, $ok) = &_exist;
+ die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)"
+ unless $ok;
+ return $rtsig;
+}
+
+sub new {
+ my ($rtsig, $handler, $flags) = @_;
+ my $sigset = POSIX::SigSet->new($rtsig);
+ my $sigact = POSIX::SigAction->new($handler,
+ $sigset,
+ $flags);
+ POSIX::sigaction($rtsig, $sigact);
+}
+
+sub EXISTS { &_exist }
+sub FETCH { my $rtsig = &_check;
+ my $oa = POSIX::SigAction->new();
+ POSIX::sigaction($rtsig, undef, $oa);
+ return $oa->{HANDLER} }
+sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) }
+sub DELETE { delete $SIG{ &_check } }
+sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
+sub SCALAR { &_croak; $_sigrtn + 1 }
diff --git a/Master/tlpkg/tlperl/lib/POSIX.pod b/Master/tlpkg/tlperl/lib/POSIX.pod
new file mode 100644
index 00000000000..64852e94b6b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/POSIX.pod
@@ -0,0 +1,2218 @@
+=head1 NAME
+
+POSIX - Perl interface to IEEE Std 1003.1
+
+=head1 SYNOPSIS
+
+ use POSIX;
+ use POSIX qw(setsid);
+ use POSIX qw(:errno_h :fcntl_h);
+
+ printf "EINTR is %d\n", EINTR;
+
+ $sess_id = POSIX::setsid();
+
+ $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644);
+ # note: that's a filedescriptor, *NOT* a filehandle
+
+=head1 DESCRIPTION
+
+The POSIX module permits you to access all (or nearly all) the standard
+POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish
+interfaces.
+
+I<Everything is exported by default> with the exception of any POSIX
+functions with the same name as a built-in Perl function, such as
+C<abs>, C<alarm>, C<rmdir>, C<write>, etc.., which will be exported
+only if you ask for them explicitly. This is an unfortunate backwards
+compatibility feature. You can stop the exporting by saying C<use
+POSIX ()> and then use the fully qualified names (ie. C<POSIX::SEEK_END>).
+
+This document gives a condensed list of the features available in the POSIX
+module. Consult your operating system's manpages for general information on
+most features. Consult L<perlfunc> for functions which are noted as being
+identical to Perl's builtin functions.
+
+The first section describes POSIX functions from the 1003.1 specification.
+The second section describes some classes for signal objects, TTY objects,
+and other miscellaneous objects. The remaining sections list various
+constants and macros in an organization which roughly follows IEEE Std
+1003.1b-1993.
+
+=head1 NOTE
+
+The POSIX module is probably the most complex Perl module supplied with
+the standard distribution. It incorporates autoloading, namespace games,
+and dynamic loading of code that's in Perl, C, or both. It's a great
+source of wisdom.
+
+=head1 CAVEATS
+
+A few functions are not implemented because they are C specific. If you
+attempt to call these, they will print a message telling you that they
+aren't implemented, and suggest using the Perl equivalent should one
+exist. For example, trying to access the setjmp() call will elicit the
+message "setjmp() is C-specific: use eval {} instead".
+
+Furthermore, some evil vendors will claim 1003.1 compliance, but in fact
+are not so: they will not pass the PCTS (POSIX Compliance Test Suites).
+For example, one vendor may not define EDEADLK, or the semantics of the
+errno values set by open(2) might not be quite right. Perl does not
+attempt to verify POSIX compliance. That means you can currently
+successfully say "use POSIX", and then later in your program you find
+that your vendor has been lax and there's no usable ICANON macro after
+all. This could be construed to be a bug.
+
+=head1 FUNCTIONS
+
+=over 8
+
+=item _exit
+
+This is identical to the C function C<_exit()>. It exits the program
+immediately which means among other things buffered I/O is B<not> flushed.
+
+Note that when using threads and in Linux this is B<not> a good way to
+exit a thread because in Linux processes and threads are kind of the
+same thing (Note: while this is the situation in early 2003 there are
+projects under way to have threads with more POSIXly semantics in Linux).
+If you want not to return from a thread, detach the thread.
+
+=item abort
+
+This is identical to the C function C<abort()>. It terminates the
+process with a C<SIGABRT> signal unless caught by a signal handler or
+if the handler does not return normally (it e.g. does a C<longjmp>).
+
+=item abs
+
+This is identical to Perl's builtin C<abs()> function, returning
+the absolute value of its numerical argument.
+
+=item access
+
+Determines the accessibility of a file.
+
+ if( POSIX::access( "/", &POSIX::R_OK ) ){
+ print "have read permission\n";
+ }
+
+Returns C<undef> on failure. Note: do not use C<access()> for
+security purposes. Between the C<access()> call and the operation
+you are preparing for the permissions might change: a classic
+I<race condition>.
+
+=item acos
+
+This is identical to the C function C<acos()>, returning
+the arcus cosine of its numerical argument. See also L<Math::Trig>.
+
+=item alarm
+
+This is identical to Perl's builtin C<alarm()> function,
+either for arming or disarming the C<SIGARLM> timer.
+
+=item asctime
+
+This is identical to the C function C<asctime()>. It returns
+a string of the form
+
+ "Fri Jun 2 18:22:13 2000\n\0"
+
+and it is called thusly
+
+ $asctime = asctime($sec, $min, $hour, $mday, $mon, $year,
+ $wday, $yday, $isdst);
+
+The C<$mon> is zero-based: January equals C<0>. The C<$year> is
+1900-based: 2001 equals C<101>. C<$wday> and C<$yday> default to zero
+(and are usually ignored anyway), and C<$isdst> defaults to -1.
+
+=item asin
+
+This is identical to the C function C<asin()>, returning
+the arcus sine of its numerical argument. See also L<Math::Trig>.
+
+=item assert
+
+Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module
+to achieve similar things.
+
+=item atan
+
+This is identical to the C function C<atan()>, returning the
+arcus tangent of its numerical argument. See also L<Math::Trig>.
+
+=item atan2
+
+This is identical to Perl's builtin C<atan2()> function, returning
+the arcus tangent defined by its two numerical arguments, the I<y>
+coordinate and the I<x> coordinate. See also L<Math::Trig>.
+
+=item atexit
+
+atexit() is C-specific: use C<END {}> instead, see L<perlsub>.
+
+=item atof
+
+atof() is C-specific. Perl converts strings to numbers transparently.
+If you need to force a scalar to a number, add a zero to it.
+
+=item atoi
+
+atoi() is C-specific. Perl converts strings to numbers transparently.
+If you need to force a scalar to a number, add a zero to it.
+If you need to have just the integer part, see L<perlfunc/int>.
+
+=item atol
+
+atol() is C-specific. Perl converts strings to numbers transparently.
+If you need to force a scalar to a number, add a zero to it.
+If you need to have just the integer part, see L<perlfunc/int>.
+
+=item bsearch
+
+bsearch() not supplied. For doing binary search on wordlists,
+see L<Search::Dict>.
+
+=item calloc
+
+calloc() is C-specific. Perl does memory management transparently.
+
+=item ceil
+
+This is identical to the C function C<ceil()>, returning the smallest
+integer value greater than or equal to the given numerical argument.
+
+=item chdir
+
+This is identical to Perl's builtin C<chdir()> function, allowing
+one to change the working (default) directory, see L<perlfunc/chdir>.
+
+=item chmod
+
+This is identical to Perl's builtin C<chmod()> function, allowing
+one to change file and directory permissions, see L<perlfunc/chmod>.
+
+=item chown
+
+This is identical to Perl's builtin C<chown()> function, allowing one
+to change file and directory owners and groups, see L<perlfunc/chown>.
+
+=item clearerr
+
+Use the method C<IO::Handle::clearerr()> instead, to reset the error
+state (if any) and EOF state (if any) of the given stream.
+
+=item clock
+
+This is identical to the C function C<clock()>, returning the
+amount of spent processor time in microseconds.
+
+=item close
+
+Close the file. This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ POSIX::close( $fd );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/close>.
+
+=item closedir
+
+This is identical to Perl's builtin C<closedir()> function for closing
+a directory handle, see L<perlfunc/closedir>.
+
+=item cos
+
+This is identical to Perl's builtin C<cos()> function, for returning
+the cosine of its numerical argument, see L<perlfunc/cos>.
+See also L<Math::Trig>.
+
+=item cosh
+
+This is identical to the C function C<cosh()>, for returning
+the hyperbolic cosine of its numeric argument. See also L<Math::Trig>.
+
+=item creat
+
+Create a new file. This returns a file descriptor like the ones returned by
+C<POSIX::open>. Use C<POSIX::close> to close the file.
+
+ $fd = POSIX::creat( "foo", 0611 );
+ POSIX::close( $fd );
+
+See also L<perlfunc/sysopen> and its C<O_CREAT> flag.
+
+=item ctermid
+
+Generates the path name for the controlling terminal.
+
+ $path = POSIX::ctermid();
+
+=item ctime
+
+This is identical to the C function C<ctime()> and equivalent
+to C<asctime(localtime(...))>, see L</asctime> and L</localtime>.
+
+=item cuserid
+
+Get the login name of the owner of the current process.
+
+ $name = POSIX::cuserid();
+
+=item difftime
+
+This is identical to the C function C<difftime()>, for returning
+the time difference (in seconds) between two times (as returned
+by C<time()>), see L</time>.
+
+=item div
+
+div() is C-specific, use L<perlfunc/int> on the usual C</> division and
+the modulus C<%>.
+
+=item dup
+
+This is similar to the C function C<dup()>, for duplicating a file
+descriptor.
+
+This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+Returns C<undef> on failure.
+
+=item dup2
+
+This is similar to the C function C<dup2()>, for duplicating a file
+descriptor to an another known file descriptor.
+
+This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+Returns C<undef> on failure.
+
+=item errno
+
+Returns the value of errno.
+
+ $errno = POSIX::errno();
+
+This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>.
+
+=item execl
+
+execl() is C-specific, see L<perlfunc/exec>.
+
+=item execle
+
+execle() is C-specific, see L<perlfunc/exec>.
+
+=item execlp
+
+execlp() is C-specific, see L<perlfunc/exec>.
+
+=item execv
+
+execv() is C-specific, see L<perlfunc/exec>.
+
+=item execve
+
+execve() is C-specific, see L<perlfunc/exec>.
+
+=item execvp
+
+execvp() is C-specific, see L<perlfunc/exec>.
+
+=item exit
+
+This is identical to Perl's builtin C<exit()> function for exiting the
+program, see L<perlfunc/exit>.
+
+=item exp
+
+This is identical to Perl's builtin C<exp()> function for
+returning the exponent (I<e>-based) of the numerical argument,
+see L<perlfunc/exp>.
+
+=item fabs
+
+This is identical to Perl's builtin C<abs()> function for returning
+the absolute value of the numerical argument, see L<perlfunc/abs>.
+
+=item fclose
+
+Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>.
+
+=item fcntl
+
+This is identical to Perl's builtin C<fcntl()> function,
+see L<perlfunc/fcntl>.
+
+=item fdopen
+
+Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>.
+
+=item feof
+
+Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>.
+
+=item ferror
+
+Use method C<IO::Handle::error()> instead.
+
+=item fflush
+
+Use method C<IO::Handle::flush()> instead.
+See also L<perlvar/$OUTPUT_AUTOFLUSH>.
+
+=item fgetc
+
+Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>.
+
+=item fgetpos
+
+Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>.
+
+=item fgets
+
+Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known
+as L<perlfunc/readline>.
+
+=item fileno
+
+Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>.
+
+=item floor
+
+This is identical to the C function C<floor()>, returning the largest
+integer value less than or equal to the numerical argument.
+
+=item fmod
+
+This is identical to the C function C<fmod()>.
+
+ $r = fmod($x, $y);
+
+It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>.
+The C<$r> has the same sign as C<$x> and magnitude (absolute value)
+less than the magnitude of C<$y>.
+
+=item fopen
+
+Use method C<IO::File::open()> instead, or see L<perlfunc/open>.
+
+=item fork
+
+This is identical to Perl's builtin C<fork()> function
+for duplicating the current process, see L<perlfunc/fork>
+and L<perlfork> if you are in Windows.
+
+=item fpathconf
+
+Retrieves the value of a configurable limit on a file or directory. This
+uses file descriptors such as those obtained by calling C<POSIX::open>.
+
+The following will determine the maximum length of the longest allowable
+pathname on the filesystem which holds C</var/foo>.
+
+ $fd = POSIX::open( "/var/foo", &POSIX::O_RDONLY );
+ $path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );
+
+Returns C<undef> on failure.
+
+=item fprintf
+
+fprintf() is C-specific, see L<perlfunc/printf> instead.
+
+=item fputc
+
+fputc() is C-specific, see L<perlfunc/print> instead.
+
+=item fputs
+
+fputs() is C-specific, see L<perlfunc/print> instead.
+
+=item fread
+
+fread() is C-specific, see L<perlfunc/read> instead.
+
+=item free
+
+free() is C-specific. Perl does memory management transparently.
+
+=item freopen
+
+freopen() is C-specific, see L<perlfunc/open> instead.
+
+=item frexp
+
+Return the mantissa and exponent of a floating-point number.
+
+ ($mantissa, $exponent) = POSIX::frexp( 1.234e56 );
+
+=item fscanf
+
+fscanf() is C-specific, use E<lt>E<gt> and regular expressions instead.
+
+=item fseek
+
+Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>.
+
+=item fsetpos
+
+Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>.
+
+=item fstat
+
+Get file status. This uses file descriptors such as those obtained by
+calling C<POSIX::open>. The data returned is identical to the data from
+Perl's builtin C<stat> function.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ @stats = POSIX::fstat( $fd );
+
+=item fsync
+
+Use method C<IO::Handle::sync()> instead.
+
+=item ftell
+
+Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>.
+
+=item fwrite
+
+fwrite() is C-specific, see L<perlfunc/print> instead.
+
+=item getc
+
+This is identical to Perl's builtin C<getc()> function,
+see L<perlfunc/getc>.
+
+=item getchar
+
+Returns one character from STDIN. Identical to Perl's C<getc()>,
+see L<perlfunc/getc>.
+
+=item getcwd
+
+Returns the name of the current working directory.
+See also L<Cwd>.
+
+=item getegid
+
+Returns the effective group identifier. Similar to Perl' s builtin
+variable C<$(>, see L<perlvar/$EGID>.
+
+=item getenv
+
+Returns the value of the specified environment variable.
+The same information is available through the C<%ENV> array.
+
+=item geteuid
+
+Returns the effective user identifier. Identical to Perl's builtin C<$E<gt>>
+variable, see L<perlvar/$EUID>.
+
+=item getgid
+
+Returns the user's real group identifier. Similar to Perl's builtin
+variable C<$)>, see L<perlvar/$GID>.
+
+=item getgrgid
+
+This is identical to Perl's builtin C<getgrgid()> function for
+returning group entries by group identifiers, see
+L<perlfunc/getgrgid>.
+
+=item getgrnam
+
+This is identical to Perl's builtin C<getgrnam()> function for
+returning group entries by group names, see L<perlfunc/getgrnam>.
+
+=item getgroups
+
+Returns the ids of the user's supplementary groups. Similar to Perl's
+builtin variable C<$)>, see L<perlvar/$GID>.
+
+=item getlogin
+
+This is identical to Perl's builtin C<getlogin()> function for
+returning the user name associated with the current session, see
+L<perlfunc/getlogin>.
+
+=item getpgrp
+
+This is identical to Perl's builtin C<getpgrp()> function for
+returning the process group identifier of the current process, see
+L<perlfunc/getpgrp>.
+
+=item getpid
+
+Returns the process identifier. Identical to Perl's builtin
+variable C<$$>, see L<perlvar/$PID>.
+
+=item getppid
+
+This is identical to Perl's builtin C<getppid()> function for
+returning the process identifier of the parent process of the current
+process , see L<perlfunc/getppid>.
+
+=item getpwnam
+
+This is identical to Perl's builtin C<getpwnam()> function for
+returning user entries by user names, see L<perlfunc/getpwnam>.
+
+=item getpwuid
+
+This is identical to Perl's builtin C<getpwuid()> function for
+returning user entries by user identifiers, see L<perlfunc/getpwuid>.
+
+=item gets
+
+Returns one line from C<STDIN>, similar to E<lt>E<gt>, also known
+as the C<readline()> function, see L<perlfunc/readline>.
+
+B<NOTE>: if you have C programs that still use C<gets()>, be very
+afraid. The C<gets()> function is a source of endless grief because
+it has no buffer overrun checks. It should B<never> be used. The
+C<fgets()> function should be preferred instead.
+
+=item getuid
+
+Returns the user's identifier. Identical to Perl's builtin C<$E<lt>> variable,
+see L<perlvar/$UID>.
+
+=item gmtime
+
+This is identical to Perl's builtin C<gmtime()> function for
+converting seconds since the epoch to a date in Greenwich Mean Time,
+see L<perlfunc/gmtime>.
+
+=item isalnum
+
+This is identical to the C function, except that it can apply to a
+single character or to a whole string. Note that locale settings may
+affect what characters are considered C<isalnum>. Does not work on
+Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:alnum:]]/> construct instead, or possibly
+the C</\w/> construct.
+
+=item isalpha
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isalpha>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:alpha:]]/> construct instead.
+
+=item isatty
+
+Returns a boolean indicating whether the specified filehandle is connected
+to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>.
+
+=item iscntrl
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<iscntrl>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:cntrl:]]/> construct instead.
+
+=item isdigit
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isdigit> (unlikely, but
+still possible). Does not work on Unicode characters code point 256
+or higher. Consider using regular expressions and the C</[[:digit:]]/>
+construct instead, or the C</\d/> construct.
+
+=item isgraph
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isgraph>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:graph:]]/> construct instead.
+
+=item islower
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<islower>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:lower:]]/> construct instead. Do B<not> use
+C</[a-z]/>.
+
+=item isprint
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isprint>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:print:]]/> construct instead.
+
+=item ispunct
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<ispunct>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:punct:]]/> construct instead.
+
+=item isspace
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isspace>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:space:]]/> construct instead, or the C</\s/>
+construct. (Note that C</\s/> and C</[[:space:]]/> are slightly
+different in that C</[[:space:]]/> can normally match a vertical tab,
+while C</\s/> does not.)
+
+=item isupper
+
+This is identical to the C function, except that it can apply to
+a single character or to a whole string. Note that locale settings
+may affect what characters are considered C<isupper>. Does not work
+on Unicode characters code point 256 or higher. Consider using regular
+expressions and the C</[[:upper:]]/> construct instead. Do B<not> use
+C</[A-Z]/>.
+
+=item isxdigit
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string. Note that locale settings may affect what
+characters are considered C<isxdigit> (unlikely, but still possible).
+Does not work on Unicode characters code point 256 or higher.
+Consider using regular expressions and the C</[[:xdigit:]]/>
+construct instead, or simply C</[0-9a-f]/i>.
+
+=item kill
+
+This is identical to Perl's builtin C<kill()> function for sending
+signals to processes (often to terminate them), see L<perlfunc/kill>.
+
+=item labs
+
+(For returning absolute values of long integers.)
+labs() is C-specific, see L<perlfunc/abs> instead.
+
+=item lchown
+
+This is identical to the C function, except the order of arguments is
+consistent with Perl's builtin C<chown()> with the added restriction
+of only one path, not an list of paths. Does the same thing as the
+C<chown()> function but changes the owner of a symbolic link instead
+of the file the symbolic link points to.
+
+=item ldexp
+
+This is identical to the C function C<ldexp()>
+for multiplying floating point numbers with powers of two.
+
+ $x_quadrupled = POSIX::ldexp($x, 2);
+
+=item ldiv
+
+(For computing dividends of long integers.)
+ldiv() is C-specific, use C</> and C<int()> instead.
+
+=item link
+
+This is identical to Perl's builtin C<link()> function
+for creating hard links into files, see L<perlfunc/link>.
+
+=item localeconv
+
+Get numeric formatting information. Returns a reference to a hash
+containing the current locale formatting values.
+
+Here is how to query the database for the B<de> (Deutsch or German) locale.
+
+ $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" );
+ print "Locale = $loc\n";
+ $lconv = POSIX::localeconv();
+ print "decimal_point = ", $lconv->{decimal_point}, "\n";
+ print "thousands_sep = ", $lconv->{thousands_sep}, "\n";
+ print "grouping = ", $lconv->{grouping}, "\n";
+ print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n";
+ print "currency_symbol = ", $lconv->{currency_symbol}, "\n";
+ print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n";
+ print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n";
+ print "mon_grouping = ", $lconv->{mon_grouping}, "\n";
+ print "positive_sign = ", $lconv->{positive_sign}, "\n";
+ print "negative_sign = ", $lconv->{negative_sign}, "\n";
+ print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n";
+ print "frac_digits = ", $lconv->{frac_digits}, "\n";
+ print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n";
+ print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n";
+ print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n";
+ print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n";
+ print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n";
+ print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n";
+
+=item localtime
+
+This is identical to Perl's builtin C<localtime()> function for
+converting seconds since the epoch to a date see L<perlfunc/localtime>.
+
+=item log
+
+This is identical to Perl's builtin C<log()> function,
+returning the natural (I<e>-based) logarithm of the numerical argument,
+see L<perlfunc/log>.
+
+=item log10
+
+This is identical to the C function C<log10()>,
+returning the 10-base logarithm of the numerical argument.
+You can also use
+
+ sub log10 { log($_[0]) / log(10) }
+
+or
+
+ sub log10 { log($_[0]) / 2.30258509299405 }
+
+or
+
+ sub log10 { log($_[0]) * 0.434294481903252 }
+
+=item longjmp
+
+longjmp() is C-specific: use L<perlfunc/die> instead.
+
+=item lseek
+
+Move the file's read/write position. This uses file descriptors such as
+those obtained by calling C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ $off_t = POSIX::lseek( $fd, 0, &POSIX::SEEK_SET );
+
+Returns C<undef> on failure.
+
+=item malloc
+
+malloc() is C-specific. Perl does memory management transparently.
+
+=item mblen
+
+This is identical to the C function C<mblen()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item mbstowcs
+
+This is identical to the C function C<mbstowcs()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item mbtowc
+
+This is identical to the C function C<mbtowc()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item memchr
+
+memchr() is C-specific, see L<perlfunc/index> instead.
+
+=item memcmp
+
+memcmp() is C-specific, use C<eq> instead, see L<perlop>.
+
+=item memcpy
+
+memcpy() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>.
+
+=item memmove
+
+memmove() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>.
+
+=item memset
+
+memset() is C-specific, use C<x> instead, see L<perlop>.
+
+=item mkdir
+
+This is identical to Perl's builtin C<mkdir()> function
+for creating directories, see L<perlfunc/mkdir>.
+
+=item mkfifo
+
+This is similar to the C function C<mkfifo()> for creating
+FIFO special files.
+
+ if (mkfifo($path, $mode)) { ....
+
+Returns C<undef> on failure. The C<$mode> is similar to the
+mode of C<mkdir()>, see L<perlfunc/mkdir>, though for C<mkfifo>
+you B<must> specify the C<$mode>.
+
+=item mktime
+
+Convert date/time info to a calendar time.
+
+Synopsis:
+
+ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
+
+The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
+I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
+year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the
+year 2001 is 101. Consult your system's C<mktime()> manpage for details
+about these and the other arguments.
+
+Calendar time for December 12, 1995, at 10:30 am.
+
+ $time_t = POSIX::mktime( 0, 30, 10, 12, 11, 95 );
+ print "Date = ", POSIX::ctime($time_t);
+
+Returns C<undef> on failure.
+
+=item modf
+
+Return the integral and fractional parts of a floating-point number.
+
+ ($fractional, $integral) = POSIX::modf( 3.14 );
+
+=item nice
+
+This is similar to the C function C<nice()>, for changing
+the scheduling preference of the current process. Positive
+arguments mean more polite process, negative values more
+needy process. Normal user processes can only be more polite.
+
+Returns C<undef> on failure.
+
+=item offsetof
+
+offsetof() is C-specific, you probably want to see L<perlfunc/pack> instead.
+
+=item open
+
+Open a file for reading for writing. This returns file descriptors, not
+Perl filehandles. Use C<POSIX::close> to close the file.
+
+Open a file read-only with mode 0666.
+
+ $fd = POSIX::open( "foo" );
+
+Open a file for read and write.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDWR );
+
+Open a file for write, with truncation.
+
+ $fd = POSIX::open( "foo", &POSIX::O_WRONLY | &POSIX::O_TRUNC );
+
+Create a new file with mode 0640. Set up the file for writing.
+
+ $fd = POSIX::open( "foo", &POSIX::O_CREAT | &POSIX::O_WRONLY, 0640 );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/sysopen>.
+
+=item opendir
+
+Open a directory for reading.
+
+ $dir = POSIX::opendir( "/var" );
+ @files = POSIX::readdir( $dir );
+ POSIX::closedir( $dir );
+
+Returns C<undef> on failure.
+
+=item pathconf
+
+Retrieves the value of a configurable limit on a file or directory.
+
+The following will determine the maximum length of the longest allowable
+pathname on the filesystem which holds C</var>.
+
+ $path_max = POSIX::pathconf( "/var", &POSIX::_PC_PATH_MAX );
+
+Returns C<undef> on failure.
+
+=item pause
+
+This is similar to the C function C<pause()>, which suspends
+the execution of the current process until a signal is received.
+
+Returns C<undef> on failure.
+
+=item perror
+
+This is identical to the C function C<perror()>, which outputs to the
+standard error stream the specified message followed by ": " and the
+current error string. Use the C<warn()> function and the C<$!>
+variable instead, see L<perlfunc/warn> and L<perlvar/$ERRNO>.
+
+=item pipe
+
+Create an interprocess channel. This returns file descriptors like those
+returned by C<POSIX::open>.
+
+ my ($read, $write) = POSIX::pipe();
+ POSIX::write( $write, "hello", 5 );
+ POSIX::read( $read, $buf, 5 );
+
+See also L<perlfunc/pipe>.
+
+=item pow
+
+Computes C<$x> raised to the power C<$exponent>.
+
+ $ret = POSIX::pow( $x, $exponent );
+
+You can also use the C<**> operator, see L<perlop>.
+
+=item printf
+
+Formats and prints the specified arguments to STDOUT.
+See also L<perlfunc/printf>.
+
+=item putc
+
+putc() is C-specific, see L<perlfunc/print> instead.
+
+=item putchar
+
+putchar() is C-specific, see L<perlfunc/print> instead.
+
+=item puts
+
+puts() is C-specific, see L<perlfunc/print> instead.
+
+=item qsort
+
+qsort() is C-specific, see L<perlfunc/sort> instead.
+
+=item raise
+
+Sends the specified signal to the current process.
+See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>.
+
+=item rand
+
+C<rand()> is non-portable, see L<perlfunc/rand> instead.
+
+=item read
+
+Read from a file. This uses file descriptors such as those obtained by
+calling C<POSIX::open>. If the buffer C<$buf> is not large enough for the
+read then Perl will extend it to make room for the request.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ $bytes = POSIX::read( $fd, $buf, 3 );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/sysread>.
+
+=item readdir
+
+This is identical to Perl's builtin C<readdir()> function
+for reading directory entries, see L<perlfunc/readdir>.
+
+=item realloc
+
+realloc() is C-specific. Perl does memory management transparently.
+
+=item remove
+
+This is identical to Perl's builtin C<unlink()> function
+for removing files, see L<perlfunc/unlink>.
+
+=item rename
+
+This is identical to Perl's builtin C<rename()> function
+for renaming files, see L<perlfunc/rename>.
+
+=item rewind
+
+Seeks to the beginning of the file.
+
+=item rewinddir
+
+This is identical to Perl's builtin C<rewinddir()> function for
+rewinding directory entry streams, see L<perlfunc/rewinddir>.
+
+=item rmdir
+
+This is identical to Perl's builtin C<rmdir()> function
+for removing (empty) directories, see L<perlfunc/rmdir>.
+
+=item scanf
+
+scanf() is C-specific, use E<lt>E<gt> and regular expressions instead,
+see L<perlre>.
+
+=item setgid
+
+Sets the real group identifier and the effective group identifier for
+this process. Similar to assigning a value to the Perl's builtin
+C<$)> variable, see L<perlvar/$EGID>, except that the latter
+will change only the real user identifier, and that the setgid()
+uses only a single numeric argument, as opposed to a space-separated
+list of numbers.
+
+=item setjmp
+
+C<setjmp()> is C-specific: use C<eval {}> instead,
+see L<perlfunc/eval>.
+
+=item setlocale
+
+Modifies and queries program's locale. The following examples assume
+
+ use POSIX qw(setlocale LC_ALL LC_CTYPE);
+
+has been issued.
+
+The following will set the traditional UNIX system locale behavior
+(the second argument C<"C">).
+
+ $loc = setlocale( LC_ALL, "C" );
+
+The following will query the current LC_CTYPE category. (No second
+argument means 'query'.)
+
+ $loc = setlocale( LC_CTYPE );
+
+The following will set the LC_CTYPE behaviour according to the locale
+environment variables (the second argument C<"">).
+Please see your systems C<setlocale(3)> documentation for the locale
+environment variables' meaning or consult L<perllocale>.
+
+ $loc = setlocale( LC_CTYPE, "" );
+
+The following will set the LC_COLLATE behaviour to Argentinian
+Spanish. B<NOTE>: The naming and availability of locales depends on
+your operating system. Please consult L<perllocale> for how to find
+out which locales are available in your system.
+
+ $loc = setlocale( LC_COLLATE, "es_AR.ISO8859-1" );
+
+=item setpgid
+
+This is similar to the C function C<setpgid()> for
+setting the process group identifier of the current process.
+
+Returns C<undef> on failure.
+
+=item setsid
+
+This is identical to the C function C<setsid()> for
+setting the session identifier of the current process.
+
+=item setuid
+
+Sets the real user identifier and the effective user identifier for
+this process. Similar to assigning a value to the Perl's builtin
+C<$E<lt>> variable, see L<perlvar/$UID>, except that the latter
+will change only the real user identifier.
+
+=item sigaction
+
+Detailed signal management. This uses C<POSIX::SigAction> objects for
+the C<action> and C<oldaction> arguments (the oldaction can also be
+just a hash reference). Consult your system's C<sigaction> manpage
+for details, see also C<POSIX::SigRt>.
+
+Synopsis:
+
+ sigaction(signal, action, oldaction = 0)
+
+Returns C<undef> on failure. The C<signal> must be a number (like
+SIGHUP), not a string (like "SIGHUP"), though Perl does try hard
+to understand you.
+
+If you use the SA_SIGINFO flag, the signal handler will in addition to
+the first argument, the signal name, also receive a second argument, a
+hash reference, inside which are the following keys with the following
+semantics, as defined by POSIX/SUSv3:
+
+ signo the signal number
+ errno the error number
+ code if this is zero or less, the signal was sent by
+ a user process and the uid and pid make sense,
+ otherwise the signal was sent by the kernel
+
+The following are also defined by POSIX/SUSv3, but unfortunately
+not very widely implemented:
+
+ pid the process id generating the signal
+ uid the uid of the process id generating the signal
+ status exit value or signal for SIGCHLD
+ band band event for SIGPOLL
+
+A third argument is also passed to the handler, which contains a copy
+of the raw binary contents of the siginfo structure: if a system has
+some non-POSIX fields, this third argument is where to unpack() them
+from.
+
+Note that not all siginfo values make sense simultaneously (some are
+valid only for certain signals, for example), and not all values make
+sense from Perl perspective, you should to consult your system's
+C<sigaction> and possibly also C<siginfo> documentation.
+
+=item siglongjmp
+
+siglongjmp() is C-specific: use L<perlfunc/die> instead.
+
+=item sigpending
+
+Examine signals that are blocked and pending. This uses C<POSIX::SigSet>
+objects for the C<sigset> argument. Consult your system's C<sigpending>
+manpage for details.
+
+Synopsis:
+
+ sigpending(sigset)
+
+Returns C<undef> on failure.
+
+=item sigprocmask
+
+Change and/or examine calling process's signal mask. This uses
+C<POSIX::SigSet> objects for the C<sigset> and C<oldsigset> arguments.
+Consult your system's C<sigprocmask> manpage for details.
+
+Synopsis:
+
+ sigprocmask(how, sigset, oldsigset = 0)
+
+Returns C<undef> on failure.
+
+=item sigsetjmp
+
+C<sigsetjmp()> is C-specific: use C<eval {}> instead,
+see L<perlfunc/eval>.
+
+=item sigsuspend
+
+Install a signal mask and suspend process until signal arrives. This uses
+C<POSIX::SigSet> objects for the C<signal_mask> argument. Consult your
+system's C<sigsuspend> manpage for details.
+
+Synopsis:
+
+ sigsuspend(signal_mask)
+
+Returns C<undef> on failure.
+
+=item sin
+
+This is identical to Perl's builtin C<sin()> function
+for returning the sine of the numerical argument,
+see L<perlfunc/sin>. See also L<Math::Trig>.
+
+=item sinh
+
+This is identical to the C function C<sinh()>
+for returning the hyperbolic sine of the numerical argument.
+See also L<Math::Trig>.
+
+=item sleep
+
+This is functionally identical to Perl's builtin C<sleep()> function
+for suspending the execution of the current for process for certain
+number of seconds, see L<perlfunc/sleep>. There is one significant
+difference, however: C<POSIX::sleep()> returns the number of
+B<unslept> seconds, while the C<CORE::sleep()> returns the
+number of slept seconds.
+
+=item sprintf
+
+This is similar to Perl's builtin C<sprintf()> function
+for returning a string that has the arguments formatted as requested,
+see L<perlfunc/sprintf>.
+
+=item sqrt
+
+This is identical to Perl's builtin C<sqrt()> function.
+for returning the square root of the numerical argument,
+see L<perlfunc/sqrt>.
+
+=item srand
+
+Give a seed the pseudorandom number generator, see L<perlfunc/srand>.
+
+=item sscanf
+
+sscanf() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item stat
+
+This is identical to Perl's builtin C<stat()> function
+for returning information about files and directories.
+
+=item strcat
+
+strcat() is C-specific, use C<.=> instead, see L<perlop>.
+
+=item strchr
+
+strchr() is C-specific, see L<perlfunc/index> instead.
+
+=item strcmp
+
+strcmp() is C-specific, use C<eq> or C<cmp> instead, see L<perlop>.
+
+=item strcoll
+
+This is identical to the C function C<strcoll()>
+for collating (comparing) strings transformed using
+the C<strxfrm()> function. Not really needed since
+Perl can do this transparently, see L<perllocale>.
+
+=item strcpy
+
+strcpy() is C-specific, use C<=> instead, see L<perlop>.
+
+=item strcspn
+
+strcspn() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item strerror
+
+Returns the error string for the specified errno.
+Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>.
+
+=item strftime
+
+Convert date and time information to string. Returns the string.
+
+Synopsis:
+
+ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
+
+The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
+I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
+year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the
+year 2001 is 101. Consult your system's C<strftime()> manpage for details
+about these and the other arguments.
+
+If you want your code to be portable, your format (C<fmt>) argument
+should use only the conversion specifiers defined by the ANSI C
+standard (C89, to play safe). These are C<aAbBcdHIjmMpSUwWxXyYZ%>.
+But even then, the B<results> of some of the conversion specifiers are
+non-portable. For example, the specifiers C<aAbBcpZ> change according
+to the locale settings of the user, and both how to set locales (the
+locale names) and what output to expect are non-standard.
+The specifier C<c> changes according to the timezone settings of the
+user and the timezone computation rules of the operating system.
+The C<Z> specifier is notoriously unportable since the names of
+timezones are non-standard. Sticking to the numeric specifiers is the
+safest route.
+
+The given arguments are made consistent as though by calling
+C<mktime()> before calling your system's C<strftime()> function,
+except that the C<isdst> value is not affected.
+
+The string for Tuesday, December 12, 1995.
+
+ $str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 );
+ print "$str\n";
+
+=item strlen
+
+strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>.
+
+=item strncat
+
+strncat() is C-specific, use C<.=> instead, see L<perlop>.
+
+=item strncmp
+
+strncmp() is C-specific, use C<eq> instead, see L<perlop>.
+
+=item strncpy
+
+strncpy() is C-specific, use C<=> instead, see L<perlop>.
+
+=item strpbrk
+
+strpbrk() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item strrchr
+
+strrchr() is C-specific, see L<perlfunc/rindex> instead.
+
+=item strspn
+
+strspn() is C-specific, use regular expressions instead,
+see L<perlre>.
+
+=item strstr
+
+This is identical to Perl's builtin C<index()> function,
+see L<perlfunc/index>.
+
+=item strtod
+
+String to double translation. Returns the parsed number and the number
+of characters in the unparsed portion of the string. Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtod. However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtod should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a floating point number use
+
+ $! = 0;
+ ($num, $n_unparsed) = POSIX::strtod($str);
+
+The second returned item and $! can be used to check for valid input:
+
+ if (($str eq '') || ($n_unparsed != 0) || $!) {
+ die "Non-numeric input $str" . ($! ? ": $!\n" : "\n");
+ }
+
+When called in a scalar context strtod returns the parsed number.
+
+=item strtok
+
+strtok() is C-specific, use regular expressions instead, see
+L<perlre>, or L<perlfunc/split>.
+
+=item strtol
+
+String to (long) integer translation. Returns the parsed number and
+the number of characters in the unparsed portion of the string. Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtol. However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtol should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a number in some base $base use
+
+ $! = 0;
+ ($num, $n_unparsed) = POSIX::strtol($str, $base);
+
+The base should be zero or between 2 and 36, inclusive. When the base
+is zero or omitted strtol will use the string itself to determine the
+base: a leading "0x" or "0X" means hexadecimal; a leading "0" means
+octal; any other leading characters mean decimal. Thus, "1234" is
+parsed as a decimal number, "01234" as an octal number, and "0x1234"
+as a hexadecimal number.
+
+The second returned item and $! can be used to check for valid input:
+
+ if (($str eq '') || ($n_unparsed != 0) || !$!) {
+ die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
+ }
+
+When called in a scalar context strtol returns the parsed number.
+
+=item strtoul
+
+String to unsigned (long) integer translation. strtoul() is identical
+to strtol() except that strtoul() only parses unsigned integers. See
+L</strtol> for details.
+
+Note: Some vendors supply strtod() and strtol() but not strtoul().
+Other vendors that do supply strtoul() parse "-1" as a valid value.
+
+=item strxfrm
+
+String transformation. Returns the transformed string.
+
+ $dst = POSIX::strxfrm( $src );
+
+Used in conjunction with the C<strcoll()> function, see L</strcoll>.
+
+Not really needed since Perl can do this transparently, see
+L<perllocale>.
+
+=item sysconf
+
+Retrieves values of system configurable variables.
+
+The following will get the machine's clock speed.
+
+ $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
+
+Returns C<undef> on failure.
+
+=item system
+
+This is identical to Perl's builtin C<system()> function, see
+L<perlfunc/system>.
+
+=item tan
+
+This is identical to the C function C<tan()>, returning the
+tangent of the numerical argument. See also L<Math::Trig>.
+
+=item tanh
+
+This is identical to the C function C<tanh()>, returning the
+hyperbolic tangent of the numerical argument. See also L<Math::Trig>.
+
+=item tcdrain
+
+This is similar to the C function C<tcdrain()> for draining
+the output queue of its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcflow
+
+This is similar to the C function C<tcflow()> for controlling
+the flow of its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcflush
+
+This is similar to the C function C<tcflush()> for flushing
+the I/O buffers of its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcgetpgrp
+
+This is identical to the C function C<tcgetpgrp()> for returning the
+process group identifier of the foreground process group of the controlling
+terminal.
+
+=item tcsendbreak
+
+This is similar to the C function C<tcsendbreak()> for sending
+a break on its argument stream.
+
+Returns C<undef> on failure.
+
+=item tcsetpgrp
+
+This is similar to the C function C<tcsetpgrp()> for setting the
+process group identifier of the foreground process group of the controlling
+terminal.
+
+Returns C<undef> on failure.
+
+=item time
+
+This is identical to Perl's builtin C<time()> function
+for returning the number of seconds since the epoch
+(whatever it is for the system), see L<perlfunc/time>.
+
+=item times
+
+The times() function returns elapsed realtime since some point in the past
+(such as system startup), user and system times for this process, and user
+and system times used by child processes. All times are returned in clock
+ticks.
+
+ ($realtime, $user, $system, $cuser, $csystem) = POSIX::times();
+
+Note: Perl's builtin C<times()> function returns four values, measured in
+seconds.
+
+=item tmpfile
+
+Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>.
+
+=item tmpnam
+
+Returns a name for a temporary file.
+
+ $tmpfile = POSIX::tmpnam();
+
+For security reasons, which are probably detailed in your system's
+documentation for the C library tmpnam() function, this interface
+should not be used; instead see L<File::Temp>.
+
+=item tolower
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string. Consider using the C<lc()> function,
+see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish
+strings.
+
+=item toupper
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string. Consider using the C<uc()> function,
+see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish
+strings.
+
+=item ttyname
+
+This is identical to the C function C<ttyname()> for returning the
+name of the current terminal.
+
+=item tzname
+
+Retrieves the time conversion information from the C<tzname> variable.
+
+ POSIX::tzset();
+ ($std, $dst) = POSIX::tzname();
+
+=item tzset
+
+This is identical to the C function C<tzset()> for setting
+the current timezone based on the environment variable C<TZ>,
+to be used by C<ctime()>, C<localtime()>, C<mktime()>, and C<strftime()>
+functions.
+
+=item umask
+
+This is identical to Perl's builtin C<umask()> function
+for setting (and querying) the file creation permission mask,
+see L<perlfunc/umask>.
+
+=item uname
+
+Get name of current operating system.
+
+ ($sysname, $nodename, $release, $version, $machine) = POSIX::uname();
+
+Note that the actual meanings of the various fields are not
+that well standardized, do not expect any great portability.
+The C<$sysname> might be the name of the operating system,
+the C<$nodename> might be the name of the host, the C<$release>
+might be the (major) release number of the operating system,
+the C<$version> might be the (minor) release number of the
+operating system, and the C<$machine> might be a hardware identifier.
+Maybe.
+
+=item ungetc
+
+Use method C<IO::Handle::ungetc()> instead.
+
+=item unlink
+
+This is identical to Perl's builtin C<unlink()> function
+for removing files, see L<perlfunc/unlink>.
+
+=item utime
+
+This is identical to Perl's builtin C<utime()> function
+for changing the time stamps of files and directories,
+see L<perlfunc/utime>.
+
+=item vfprintf
+
+vfprintf() is C-specific, see L<perlfunc/printf> instead.
+
+=item vprintf
+
+vprintf() is C-specific, see L<perlfunc/printf> instead.
+
+=item vsprintf
+
+vsprintf() is C-specific, see L<perlfunc/sprintf> instead.
+
+=item wait
+
+This is identical to Perl's builtin C<wait()> function,
+see L<perlfunc/wait>.
+
+=item waitpid
+
+Wait for a child process to change state. This is identical to Perl's
+builtin C<waitpid()> function, see L<perlfunc/waitpid>.
+
+ $pid = POSIX::waitpid( -1, POSIX::WNOHANG );
+ print "status = ", ($? / 256), "\n";
+
+=item wcstombs
+
+This is identical to the C function C<wcstombs()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item wctomb
+
+This is identical to the C function C<wctomb()>.
+Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather
+useless function.
+
+=item write
+
+Write to a file. This uses file descriptors such as those obtained by
+calling C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_WRONLY );
+ $buf = "hello";
+ $bytes = POSIX::write( $fd, $buf, 5 );
+
+Returns C<undef> on failure.
+
+See also L<perlfunc/syswrite>.
+
+=back
+
+=head1 CLASSES
+
+=head2 POSIX::SigAction
+
+=over 8
+
+=item new
+
+Creates a new C<POSIX::SigAction> object which corresponds to the C
+C<struct sigaction>. This object will be destroyed automatically when
+it is no longer needed. The first parameter is the handler, a sub
+reference. The second parameter is a C<POSIX::SigSet> object, it
+defaults to the empty set. The third parameter contains the
+C<sa_flags>, it defaults to 0.
+
+ $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT);
+ $sigaction = POSIX::SigAction->new( \&handler, $sigset, &POSIX::SA_NOCLDSTOP );
+
+This C<POSIX::SigAction> object is intended for use with the C<POSIX::sigaction()>
+function.
+
+=back
+
+=over 8
+
+=item handler
+
+=item mask
+
+=item flags
+
+accessor functions to get/set the values of a SigAction object.
+
+ $sigset = $sigaction->mask;
+ $sigaction->flags(&POSIX::SA_RESTART);
+
+=item safe
+
+accessor function for the "safe signals" flag of a SigAction object; see
+L<perlipc> for general information on safe (a.k.a. "deferred") signals. If
+you wish to handle a signal safely, use this accessor to set the "safe" flag
+in the C<POSIX::SigAction> object:
+
+ $sigaction->safe(1);
+
+You may also examine the "safe" flag on the output action object which is
+filled in when given as the third parameter to C<POSIX::sigaction()>:
+
+ sigaction(SIGINT, $new_action, $old_action);
+ if ($old_action->safe) {
+ # previous SIGINT handler used safe signals
+ }
+
+=back
+
+=head2 POSIX::SigRt
+
+=over 8
+
+=item %SIGRT
+
+A hash of the POSIX realtime signal handlers. It is an extension of
+the standard %SIG, the $POSIX::SIGRT{SIGRTMIN} is roughly equivalent
+to $SIG{SIGRTMIN}, but the right POSIX moves (see below) are made with
+the POSIX::SigSet and POSIX::sigaction instead of accessing the %SIG.
+
+You can set the %POSIX::SIGRT elements to set the POSIX realtime
+signal handlers, use C<delete> and C<exists> on the elements, and use
+C<scalar> on the C<%POSIX::SIGRT> to find out how many POSIX realtime
+signals there are available (SIGRTMAX - SIGRTMIN + 1, the SIGRTMAX is
+a valid POSIX realtime signal).
+
+Setting the %SIGRT elements is equivalent to calling this:
+
+ sub new {
+ my ($rtsig, $handler, $flags) = @_;
+ my $sigset = POSIX::SigSet($rtsig);
+ my $sigact = POSIX::SigAction->new($handler, $sigset, $flags);
+ sigaction($rtsig, $sigact);
+ }
+
+The flags default to zero, if you want something different you can
+either use C<local> on $POSIX::SigRt::SIGACTION_FLAGS, or you can
+derive from POSIX::SigRt and define your own C<new()> (the tied hash
+STORE method of the %SIGRT calls C<new($rtsig, $handler, $SIGACTION_FLAGS)>,
+where the $rtsig ranges from zero to SIGRTMAX - SIGRTMIN + 1).
+
+Just as with any signal, you can use sigaction($rtsig, undef, $oa) to
+retrieve the installed signal handler (or, rather, the signal action).
+
+B<NOTE:> whether POSIX realtime signals really work in your system, or
+whether Perl has been compiled so that it works with them, is outside
+of this discussion.
+
+=item SIGRTMIN
+
+Return the minimum POSIX realtime signal number available, or C<undef>
+if no POSIX realtime signals are available.
+
+=item SIGRTMAX
+
+Return the maximum POSIX realtime signal number available, or C<undef>
+if no POSIX realtime signals are available.
+
+=back
+
+=head2 POSIX::SigSet
+
+=over 8
+
+=item new
+
+Create a new SigSet object. This object will be destroyed automatically
+when it is no longer needed. Arguments may be supplied to initialize the
+set.
+
+Create an empty set.
+
+ $sigset = POSIX::SigSet->new;
+
+Create a set with SIGUSR1.
+
+ $sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 );
+
+=item addset
+
+Add a signal to a SigSet object.
+
+ $sigset->addset( &POSIX::SIGUSR2 );
+
+Returns C<undef> on failure.
+
+=item delset
+
+Remove a signal from the SigSet object.
+
+ $sigset->delset( &POSIX::SIGUSR2 );
+
+Returns C<undef> on failure.
+
+=item emptyset
+
+Initialize the SigSet object to be empty.
+
+ $sigset->emptyset();
+
+Returns C<undef> on failure.
+
+=item fillset
+
+Initialize the SigSet object to include all signals.
+
+ $sigset->fillset();
+
+Returns C<undef> on failure.
+
+=item ismember
+
+Tests the SigSet object to see if it contains a specific signal.
+
+ if( $sigset->ismember( &POSIX::SIGUSR1 ) ){
+ print "contains SIGUSR1\n";
+ }
+
+=back
+
+=head2 POSIX::Termios
+
+=over 8
+
+=item new
+
+Create a new Termios object. This object will be destroyed automatically
+when it is no longer needed. A Termios object corresponds to the termios
+C struct. new() mallocs a new one, getattr() fills it from a file descriptor,
+and setattr() sets a file descriptor's parameters to match Termios' contents.
+
+ $termios = POSIX::Termios->new;
+
+=item getattr
+
+Get terminal control attributes.
+
+Obtain the attributes for stdin.
+
+ $termios->getattr( 0 ) # Recommended for clarity.
+ $termios->getattr()
+
+Obtain the attributes for stdout.
+
+ $termios->getattr( 1 )
+
+Returns C<undef> on failure.
+
+=item getcc
+
+Retrieve a value from the c_cc field of a termios object. The c_cc field is
+an array so an index must be specified.
+
+ $c_cc[1] = $termios->getcc(1);
+
+=item getcflag
+
+Retrieve the c_cflag field of a termios object.
+
+ $c_cflag = $termios->getcflag;
+
+=item getiflag
+
+Retrieve the c_iflag field of a termios object.
+
+ $c_iflag = $termios->getiflag;
+
+=item getispeed
+
+Retrieve the input baud rate.
+
+ $ispeed = $termios->getispeed;
+
+=item getlflag
+
+Retrieve the c_lflag field of a termios object.
+
+ $c_lflag = $termios->getlflag;
+
+=item getoflag
+
+Retrieve the c_oflag field of a termios object.
+
+ $c_oflag = $termios->getoflag;
+
+=item getospeed
+
+Retrieve the output baud rate.
+
+ $ospeed = $termios->getospeed;
+
+=item setattr
+
+Set terminal control attributes.
+
+Set attributes immediately for stdout.
+
+ $termios->setattr( 1, &POSIX::TCSANOW );
+
+Returns C<undef> on failure.
+
+=item setcc
+
+Set a value in the c_cc field of a termios object. The c_cc field is an
+array so an index must be specified.
+
+ $termios->setcc( &POSIX::VEOF, 1 );
+
+=item setcflag
+
+Set the c_cflag field of a termios object.
+
+ $termios->setcflag( $c_cflag | &POSIX::CLOCAL );
+
+=item setiflag
+
+Set the c_iflag field of a termios object.
+
+ $termios->setiflag( $c_iflag | &POSIX::BRKINT );
+
+=item setispeed
+
+Set the input baud rate.
+
+ $termios->setispeed( &POSIX::B9600 );
+
+Returns C<undef> on failure.
+
+=item setlflag
+
+Set the c_lflag field of a termios object.
+
+ $termios->setlflag( $c_lflag | &POSIX::ECHO );
+
+=item setoflag
+
+Set the c_oflag field of a termios object.
+
+ $termios->setoflag( $c_oflag | &POSIX::OPOST );
+
+=item setospeed
+
+Set the output baud rate.
+
+ $termios->setospeed( &POSIX::B9600 );
+
+Returns C<undef> on failure.
+
+=item Baud rate values
+
+B38400 B75 B200 B134 B300 B1800 B150 B0 B19200 B1200 B9600 B600 B4800 B50 B2400 B110
+
+=item Terminal interface values
+
+TCSADRAIN TCSANOW TCOON TCIOFLUSH TCOFLUSH TCION TCIFLUSH TCSAFLUSH TCIOFF TCOOFF
+
+=item c_cc field values
+
+VEOF VEOL VERASE VINTR VKILL VQUIT VSUSP VSTART VSTOP VMIN VTIME NCCS
+
+=item c_cflag field values
+
+CLOCAL CREAD CSIZE CS5 CS6 CS7 CS8 CSTOPB HUPCL PARENB PARODD
+
+=item c_iflag field values
+
+BRKINT ICRNL IGNBRK IGNCR IGNPAR INLCR INPCK ISTRIP IXOFF IXON PARMRK
+
+=item c_lflag field values
+
+ECHO ECHOE ECHOK ECHONL ICANON IEXTEN ISIG NOFLSH TOSTOP
+
+=item c_oflag field values
+
+OPOST
+
+=back
+
+=head1 PATHNAME CONSTANTS
+
+=over 8
+
+=item Constants
+
+_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE
+
+=back
+
+=head1 POSIX CONSTANTS
+
+=over 8
+
+=item Constants
+
+_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION
+
+=back
+
+=head1 SYSTEM CONFIGURATION
+
+=over 8
+
+=item Constants
+
+_SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
+
+=back
+
+=head1 ERRNO
+
+=over 8
+
+=item Constants
+
+E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF
+EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ
+EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR
+EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG
+ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC
+ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE
+EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS
+ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS
+ETXTBSY EUSERS EWOULDBLOCK EXDEV
+
+=back
+
+=head1 FCNTL
+
+=over 8
+
+=item Constants
+
+FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY
+
+=back
+
+=head1 FLOAT
+
+=over 8
+
+=item Constants
+
+DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP
+
+=back
+
+=head1 LIMITS
+
+=over 8
+
+=item Constants
+
+ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX
+
+=back
+
+=head1 LOCALE
+
+=over 8
+
+=item Constants
+
+LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME
+
+=back
+
+=head1 MATH
+
+=over 8
+
+=item Constants
+
+HUGE_VAL
+
+=back
+
+=head1 SIGNAL
+
+=over 8
+
+=item Constants
+
+SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART
+SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT
+SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU
+SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK
+SIG_UNBLOCK
+
+=back
+
+=head1 STAT
+
+=over 8
+
+=item Constants
+
+S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
+
+=item Macros
+
+S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
+
+=back
+
+=head1 STDLIB
+
+=over 8
+
+=item Constants
+
+EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX RAND_MAX
+
+=back
+
+=head1 STDIO
+
+=over 8
+
+=item Constants
+
+BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid L_tmpname TMP_MAX
+
+=back
+
+=head1 TIME
+
+=over 8
+
+=item Constants
+
+CLK_TCK CLOCKS_PER_SEC
+
+=back
+
+=head1 UNISTD
+
+=over 8
+
+=item Constants
+
+R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK
+
+=back
+
+=head1 WAIT
+
+=over 8
+
+=item Constants
+
+WNOHANG WUNTRACED
+
+=over 16
+
+=item WNOHANG
+
+Do not suspend the calling process until a child process
+changes state but instead return immediately.
+
+=item WUNTRACED
+
+Catch stopped child processes.
+
+=back
+
+=item Macros
+
+WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG
+
+=over 16
+
+=item WIFEXITED
+
+WIFEXITED($?) returns true if the child process exited normally
+(C<exit()> or by falling off the end of C<main()>)
+
+=item WEXITSTATUS
+
+WEXITSTATUS($?) returns the normal exit status of the child process
+(only meaningful if WIFEXITED($?) is true)
+
+=item WIFSIGNALED
+
+WIFSIGNALED($?) returns true if the child process terminated because
+of a signal
+
+=item WTERMSIG
+
+WTERMSIG($?) returns the signal the child process terminated for
+(only meaningful if WIFSIGNALED($?) is true)
+
+=item WIFSTOPPED
+
+WIFSTOPPED($?) returns true if the child process is currently stopped
+(can happen only if you specified the WUNTRACED flag to waitpid())
+
+=item WSTOPSIG
+
+WSTOPSIG($?) returns the signal the child process was stopped for
+(only meaningful if WIFSTOPPED($?) is true)
+
+=back
+
+=back
+
diff --git a/Master/tlpkg/tlperl/lib/PerlIO.pm b/Master/tlpkg/tlperl/lib/PerlIO.pm
new file mode 100644
index 00000000000..f4a01974b65
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/PerlIO.pm
@@ -0,0 +1,344 @@
+package PerlIO;
+
+our $VERSION = '1.06';
+
+# Map layer name to package that defines it
+our %alias;
+
+sub import
+{
+ my $class = shift;
+ while (@_)
+ {
+ my $layer = shift;
+ if (exists $alias{$layer})
+ {
+ $layer = $alias{$layer}
+ }
+ else
+ {
+ $layer = "${class}::$layer";
+ }
+ eval "require $layer";
+ warn $@ if $@;
+ }
+}
+
+sub F_UTF8 () { 0x8000 }
+
+1;
+__END__
+
+=head1 NAME
+
+PerlIO - On demand loader for PerlIO layers and root of PerlIO::* name space
+
+=head1 SYNOPSIS
+
+ open($fh,"<:crlf", "my.txt"); # support platform-native and CRLF text files
+
+ open($fh,"<","his.jpg"); # portably open a binary file for reading
+ binmode($fh);
+
+ Shell:
+ PERLIO=perlio perl ....
+
+=head1 DESCRIPTION
+
+When an undefined layer 'foo' is encountered in an C<open> or
+C<binmode> layer specification then C code performs the equivalent of:
+
+ use PerlIO 'foo';
+
+The perl code in PerlIO.pm then attempts to locate a layer by doing
+
+ require PerlIO::foo;
+
+Otherwise the C<PerlIO> package is a place holder for additional
+PerlIO related functions.
+
+The following layers are currently defined:
+
+=over 4
+
+=item :unix
+
+Lowest level layer which provides basic PerlIO operations in terms of
+UNIX/POSIX numeric file descriptor calls
+(open(), read(), write(), lseek(), close()).
+
+=item :stdio
+
+Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc. Note
+that as this is "real" stdio it will ignore any layers beneath it and
+go straight to the operating system via the C library as usual.
+
+=item :perlio
+
+A from scratch implementation of buffering for PerlIO. Provides fast
+access to the buffer for C<sv_gets> which implements perl's readline/E<lt>E<gt>
+and in general attempts to minimize data copying.
+
+C<:perlio> will insert a C<:unix> layer below itself to do low level IO.
+
+=item :crlf
+
+A layer that implements DOS/Windows like CRLF line endings. On read
+converts pairs of CR,LF to a single "\n" newline character. On write
+converts each "\n" to a CR,LF pair. Note that this layer likes to be
+one of its kind: it silently ignores attempts to be pushed into the
+layer stack more than once.
+
+It currently does I<not> mimic MS-DOS as far as treating of Control-Z
+as being an end-of-file marker.
+
+(Gory details follow) To be more exact what happens is this: after
+pushing itself to the stack, the C<:crlf> layer checks all the layers
+below itself to find the first layer that is capable of being a CRLF
+layer but is not yet enabled to be a CRLF layer. If it finds such a
+layer, it enables the CRLFness of that other deeper layer, and then
+pops itself off the stack. If not, fine, use the one we just pushed.
+
+The end result is that a C<:crlf> means "please enable the first CRLF
+layer you can find, and if you can't find one, here would be a good
+spot to place a new one."
+
+Based on the C<:perlio> layer.
+
+=item :mmap
+
+A layer which implements "reading" of files by using C<mmap()> to
+make a (whole) file appear in the process's address space, and then
+using that as PerlIO's "buffer". This I<may> be faster in certain
+circumstances for large files, and may result in less physical memory
+use when multiple processes are reading the same file.
+
+Files which are not C<mmap()>-able revert to behaving like the C<:perlio>
+layer. Writes also behave like the C<:perlio> layer, as C<mmap()> for write
+needs extra house-keeping (to extend the file) which negates any advantage.
+
+The C<:mmap> layer will not exist if the platform does not support C<mmap()>.
+
+=item :utf8
+
+Declares that the stream accepts perl's I<internal> encoding of
+characters. (Which really is UTF-8 on ASCII machines, but is
+UTF-EBCDIC on EBCDIC machines.) This allows any character perl can
+represent to be read from or written to the stream. The UTF-X encoding
+is chosen to render simple text parts (i.e. non-accented letters,
+digits and common punctuation) human readable in the encoded file.
+
+Here is how to write your native data out using UTF-8 (or UTF-EBCDIC)
+and then read it back in.
+
+ open(F, ">:utf8", "data.utf");
+ print F $out;
+ close(F);
+
+ open(F, "<:utf8", "data.utf");
+ $in = <F>;
+ close(F);
+
+Note that this layer does not validate byte sequences. For reading
+input, using C<:encoding(utf8)> instead of bare C<:utf8> is strongly
+recommended.
+
+=item :bytes
+
+This is the inverse of the C<:utf8> layer. It turns off the flag
+on the layer below so that data read from it is considered to
+be "octets" i.e. characters in the range 0..255 only. Likewise
+on output perl will warn if a "wide" character is written
+to a such a stream.
+
+=item :raw
+
+The C<:raw> layer is I<defined> as being identical to calling
+C<binmode($fh)> - the stream is made suitable for passing binary data,
+i.e. each byte is passed as-is. The stream will still be
+buffered.
+
+In Perl 5.6 and some books the C<:raw> layer (previously sometimes also
+referred to as a "discipline") is documented as the inverse of the
+C<:crlf> layer. That is no longer the case - other layers which would
+alter the binary nature of the stream are also disabled. If you want UNIX
+line endings on a platform that normally does CRLF translation, but still
+want UTF-8 or encoding defaults, the appropriate thing to do is to add
+C<:perlio> to the PERLIO environment variable.
+
+The implementation of C<:raw> is as a pseudo-layer which when "pushed"
+pops itself and then any layers which do not declare themselves as suitable
+for binary data. (Undoing :utf8 and :crlf are implemented by clearing
+flags rather than popping layers but that is an implementation detail.)
+
+As a consequence of the fact that C<:raw> normally pops layers,
+it usually only makes sense to have it as the only or first element in
+a layer specification. When used as the first element it provides
+a known base on which to build e.g.
+
+ open($fh,":raw:utf8",...)
+
+will construct a "binary" stream, but then enable UTF-8 translation.
+
+=item :pop
+
+A pseudo layer that removes the top-most layer. Gives perl code
+a way to manipulate the layer stack. Should be considered
+as experimental. Note that C<:pop> only works on real layers
+and will not undo the effects of pseudo layers like C<:utf8>.
+An example of a possible use might be:
+
+ open($fh,...)
+ ...
+ binmode($fh,":encoding(...)"); # next chunk is encoded
+ ...
+ binmode($fh,":pop"); # back to un-encoded
+
+A more elegant (and safer) interface is needed.
+
+=item :win32
+
+On Win32 platforms this I<experimental> layer uses the native "handle" IO
+rather than the unix-like numeric file descriptor layer. Known to be
+buggy as of perl 5.8.2.
+
+=back
+
+=head2 Custom Layers
+
+It is possible to write custom layers in addition to the above builtin
+ones, both in C/XS and Perl. Two such layers (and one example written
+in Perl using the latter) come with the Perl distribution.
+
+=over 4
+
+=item :encoding
+
+Use C<:encoding(ENCODING)> either in open() or binmode() to install
+a layer that transparently does character set and encoding transformations,
+for example from Shift-JIS to Unicode. Note that under C<stdio>
+an C<:encoding> also enables C<:utf8>. See L<PerlIO::encoding>
+for more information.
+
+=item :via
+
+Use C<:via(MODULE)> either in open() or binmode() to install a layer
+that does whatever transformation (for example compression /
+decompression, encryption / decryption) to the filehandle.
+See L<PerlIO::via> for more information.
+
+=back
+
+=head2 Alternatives to raw
+
+To get a binary stream an alternate method is to use:
+
+ open($fh,"whatever")
+ binmode($fh);
+
+this has the advantage of being backward compatible with how such things have
+had to be coded on some platforms for years.
+
+To get an unbuffered stream specify an unbuffered layer (e.g. C<:unix>)
+in the open call:
+
+ open($fh,"<:unix",$path)
+
+=head2 Defaults and how to override them
+
+If the platform is MS-DOS like and normally does CRLF to "\n"
+translation for text files then the default layers are :
+
+ unix crlf
+
+(The low level "unix" layer may be replaced by a platform specific low
+level layer.)
+
+Otherwise if C<Configure> found out how to do "fast" IO using the system's
+stdio, then the default layers are:
+
+ unix stdio
+
+Otherwise the default layers are
+
+ unix perlio
+
+These defaults may change once perlio has been better tested and tuned.
+
+The default can be overridden by setting the environment variable
+PERLIO to a space separated list of layers (C<unix> or platform low
+level layer is always pushed first).
+
+This can be used to see the effect of/bugs in the various layers e.g.
+
+ cd .../perl/t
+ PERLIO=stdio ./perl harness
+ PERLIO=perlio ./perl harness
+
+For the various values of PERLIO see L<perlrun/PERLIO>.
+
+=head2 Querying the layers of filehandles
+
+The following returns the B<names> of the PerlIO layers on a filehandle.
+
+ my @layers = PerlIO::get_layers($fh); # Or FH, *FH, "FH".
+
+The layers are returned in the order an open() or binmode() call would
+use them. Note that the "default stack" depends on the operating
+system and on the Perl version, and both the compile-time and
+runtime configurations of Perl.
+
+The following table summarizes the default layers on UNIX-like and
+DOS-like platforms and depending on the setting of C<$ENV{PERLIO}>:
+
+ PERLIO UNIX-like DOS-like
+ ------ --------- --------
+ unset / "" unix perlio / stdio [1] unix crlf
+ stdio unix perlio / stdio [1] stdio
+ perlio unix perlio unix perlio
+ mmap unix mmap unix mmap
+
+ # [1] "stdio" if Configure found out how to do "fast stdio" (depends
+ # on the stdio implementation) and in Perl 5.8, otherwise "unix perlio"
+
+By default the layers from the input side of the filehandle are
+returned; to get the output side, use the optional C<output> argument:
+
+ my @layers = PerlIO::get_layers($fh, output => 1);
+
+(Usually the layers are identical on either side of a filehandle but
+for example with sockets there may be differences, or if you have
+been using the C<open> pragma.)
+
+There is no set_layers(), nor does get_layers() return a tied array
+mirroring the stack, or anything fancy like that. This is not
+accidental or unintentional. The PerlIO layer stack is a bit more
+complicated than just a stack (see for example the behaviour of C<:raw>).
+You are supposed to use open() and binmode() to manipulate the stack.
+
+B<Implementation details follow, please close your eyes.>
+
+The arguments to layers are by default returned in parentheses after
+the name of the layer, and certain layers (like C<utf8>) are not real
+layers but instead flags on real layers; to get all of these returned
+separately, use the optional C<details> argument:
+
+ my @layer_and_args_and_flags = PerlIO::get_layers($fh, details => 1);
+
+The result will be up to be three times the number of layers:
+the first element will be a name, the second element the arguments
+(unspecified arguments will be C<undef>), the third element the flags,
+the fourth element a name again, and so forth.
+
+B<You may open your eyes now.>
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt>
+
+=head1 SEE ALSO
+
+L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<perliol>,
+L<Encode>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/SDBM_File.pm b/Master/tlpkg/tlperl/lib/SDBM_File.pm
new file mode 100644
index 00000000000..d1209e0158b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/SDBM_File.pm
@@ -0,0 +1,116 @@
+package SDBM_File;
+
+use strict;
+use warnings;
+
+require Tie::Hash;
+use XSLoader ();
+
+our @ISA = qw(Tie::Hash);
+our $VERSION = "1.06";
+
+XSLoader::load 'SDBM_File', $VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+SDBM_File - Tied access to sdbm files
+
+=head1 SYNOPSIS
+
+ use Fcntl; # For O_RDWR, O_CREAT, etc.
+ use SDBM_File;
+
+ tie(%h, 'SDBM_File', 'filename', O_RDWR|O_CREAT, 0666)
+ or die "Couldn't tie SDBM file 'filename': $!; aborting";
+
+ # Now read and change the hash
+ $h{newkey} = newvalue;
+ print $h{oldkey};
+ ...
+
+ untie %h;
+
+=head1 DESCRIPTION
+
+C<SDBM_File> establishes a connection between a Perl hash variable and
+a file in SDBM_File format;. You can manipulate the data in the file
+just as if it were in a Perl hash, but when your program exits, the
+data will remain in the file, to be used the next time your program
+runs.
+
+Use C<SDBM_File> with the Perl built-in C<tie> function to establish
+the connection between the variable and the file. The arguments to
+C<tie> should be:
+
+=over 4
+
+=item 1.
+
+The hash variable you want to tie.
+
+=item 2.
+
+The string C<"SDBM_File">. (Ths tells Perl to use the C<SDBM_File>
+package to perform the functions of the hash.)
+
+=item 3.
+
+The name of the file you want to tie to the hash.
+
+=item 4.
+
+Flags. Use one of:
+
+=over 2
+
+=item C<O_RDONLY>
+
+Read-only access to the data in the file.
+
+=item C<O_WRONLY>
+
+Write-only access to the data in the file.
+
+=item C<O_RDWR>
+
+Both read and write access.
+
+=back
+
+If you want to create the file if it does not exist, add C<O_CREAT> to
+any of these, as in the example. If you omit C<O_CREAT> and the file
+does not already exist, the C<tie> call will fail.
+
+=item 5.
+
+The default permissions to use if a new file is created. The actual
+permissions will be modified by the user's umask, so you should
+probably use 0666 here. (See L<perlfunc/umask>.)
+
+=back
+
+=head1 DIAGNOSTICS
+
+On failure, the C<tie> call returns an undefined value and probably
+sets C<$!> to contain the reason the file could not be tied.
+
+=head2 C<sdbm store returned -1, errno 22, key "..." at ...>
+
+This warning is emitted when you try to store a key or a value that
+is too long. It means that the change was not recorded in the
+database. See BUGS AND WARNINGS below.
+
+=head1 BUGS AND WARNINGS
+
+There are a number of limits on the size of the data that you can
+store in the SDBM file. The most important is that the length of a
+key, plus the length of its associated value, may not exceed 1008
+bytes.
+
+See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Safe.pm b/Master/tlpkg/tlperl/lib/Safe.pm
new file mode 100644
index 00000000000..bca4dfe8e6b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Safe.pm
@@ -0,0 +1,794 @@
+package Safe;
+
+use 5.003_11;
+use strict;
+use Scalar::Util qw(reftype);
+
+$Safe::VERSION = "2.27";
+
+# *** Don't declare any lexicals above this point ***
+#
+# This function should return a closure which contains an eval that can't
+# see any lexicals in scope (apart from __ExPr__ which is unavoidable)
+
+sub lexless_anon_sub {
+ # $_[0] is package;
+ # $_[1] is strict flag;
+ my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
+ # can be used to pass the value into the safe
+ # world
+
+ # Create anon sub ref in root of compartment.
+ # Uses a closure (on $__ExPr__) to pass in the code to be executed.
+ # (eval on one line to keep line numbers as expected by caller)
+ eval sprintf
+ 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
+ $_[0], $_[1] ? 'use' : 'no';
+}
+
+use Carp;
+BEGIN { eval q{
+ use Carp::Heavy;
+} }
+
+use B ();
+BEGIN {
+ no strict 'refs';
+ if (defined &B::sub_generation) {
+ *sub_generation = \&B::sub_generation;
+ }
+ else {
+ # fake sub generation changing for perls < 5.8.9
+ my $sg; *sub_generation = sub { ++$sg };
+ }
+}
+
+use Opcode 1.01, qw(
+ opset opset_to_ops opmask_add
+ empty_opset full_opset invert_opset verify_opset
+ opdesc opcodes opmask define_optag opset_to_hex
+);
+
+*ops_to_opset = \&opset; # Temporary alias for old Penguins
+
+# Regular expressions and other unicode-aware code may need to call
+# utf8->SWASHNEW (via perl's utf8.c). That will fail unless we share the
+# SWASHNEW method.
+# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
+# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
+# and sharing makes it look like the method exists.
+# The simplest and most robust fix is to ensure the utf8 module is loaded when
+# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
+require utf8;
+# we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
+# but without depending on knowledge of that implementation detail.
+# This code (//i on a unicode string) ensures utf8 is fully loaded
+# and also loads the ToFold SWASH.
+# (Swashes are cached internally by perl in PL_utf8_* variables
+# independent of being inside/outside of Safe. So once loaded they can be)
+do { my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i };
+# now we can safely include utf8::SWASHNEW in $default_share defined below.
+
+my $default_root = 0;
+# share *_ and functions defined in universal.c
+# Don't share stuff like *UNIVERSAL:: otherwise code from the
+# compartment can 0wn functions in UNIVERSAL
+my $default_share = [qw[
+ *_
+ &PerlIO::get_layers
+ &UNIVERSAL::isa
+ &UNIVERSAL::can
+ &UNIVERSAL::VERSION
+ &utf8::is_utf8
+ &utf8::valid
+ &utf8::encode
+ &utf8::decode
+ &utf8::upgrade
+ &utf8::downgrade
+ &utf8::native_to_unicode
+ &utf8::unicode_to_native
+ &utf8::SWASHNEW
+ $version::VERSION
+ $version::CLASS
+ $version::STRICT
+ $version::LAX
+ @version::ISA
+], ($] < 5.010 && qw[
+ &utf8::SWASHGET
+]), ($] >= 5.008001 && qw[
+ &Regexp::DESTROY
+]), ($] >= 5.010 && qw[
+ &re::is_regexp
+ &re::regname
+ &re::regnames
+ &re::regnames_count
+ &Tie::Hash::NamedCapture::FETCH
+ &Tie::Hash::NamedCapture::STORE
+ &Tie::Hash::NamedCapture::DELETE
+ &Tie::Hash::NamedCapture::CLEAR
+ &Tie::Hash::NamedCapture::EXISTS
+ &Tie::Hash::NamedCapture::FIRSTKEY
+ &Tie::Hash::NamedCapture::NEXTKEY
+ &Tie::Hash::NamedCapture::SCALAR
+ &Tie::Hash::NamedCapture::flags
+ &UNIVERSAL::DOES
+ &version::()
+ &version::new
+ &version::(""
+ &version::stringify
+ &version::(0+
+ &version::numify
+ &version::normal
+ &version::(cmp
+ &version::(<=>
+ &version::vcmp
+ &version::(bool
+ &version::boolean
+ &version::(nomethod
+ &version::noop
+ &version::is_alpha
+ &version::qv
+ &version::vxs::declare
+ &version::vxs::qv
+ &version::vxs::_VERSION
+ &version::vxs::stringify
+ &version::vxs::new
+ &version::vxs::parse
+]), ($] >= 5.011 && qw[
+ &re::regexp_pattern
+])];
+
+sub new {
+ my($class, $root, $mask) = @_;
+ my $obj = {};
+ bless $obj, $class;
+
+ if (defined($root)) {
+ croak "Can't use \"$root\" as root name"
+ if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+ $obj->{Root} = $root;
+ $obj->{Erase} = 0;
+ }
+ else {
+ $obj->{Root} = "Safe::Root".$default_root++;
+ $obj->{Erase} = 1;
+ }
+
+ # use permit/deny methods instead till interface issues resolved
+ # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
+ croak "Mask parameter to new no longer supported" if defined $mask;
+ $obj->permit_only(':default');
+
+ # We must share $_ and @_ with the compartment or else ops such
+ # as split, length and so on won't default to $_ properly, nor
+ # will passing argument to subroutines work (via @_). In fact,
+ # for reasons I don't completely understand, we need to share
+ # the whole glob *_ rather than $_ and @_ separately, otherwise
+ # @_ in non default packages within the compartment don't work.
+ $obj->share_from('main', $default_share);
+
+ Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
+
+ return $obj;
+}
+
+sub DESTROY {
+ my $obj = shift;
+ $obj->erase('DESTROY') if $obj->{Erase};
+}
+
+sub erase {
+ my ($obj, $action) = @_;
+ my $pkg = $obj->root();
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ # The 'my $foo' is needed! Without it you get an
+ # 'Attempt to free unreferenced scalar' warning!
+ my $stem_symtab = *{$stem}{HASH};
+
+ #warn "erase($pkg) stem=$stem, leaf=$leaf";
+ #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
+ # ", join(', ', %$stem_symtab),"\n";
+
+# delete $stem_symtab->{$leaf};
+
+ my $leaf_glob = $stem_symtab->{$leaf};
+ my $leaf_symtab = *{$leaf_glob}{HASH};
+# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
+ %$leaf_symtab = ();
+ #delete $leaf_symtab->{'__ANON__'};
+ #delete $leaf_symtab->{'foo'};
+ #delete $leaf_symtab->{'main::'};
+# my $foo = undef ${"$stem\::"}{"$leaf\::"};
+
+ if ($action and $action eq 'DESTROY') {
+ delete $stem_symtab->{$leaf};
+ } else {
+ $obj->share_from('main', $default_share);
+ }
+ 1;
+}
+
+
+sub reinit {
+ my $obj= shift;
+ $obj->erase;
+ $obj->share_redo;
+}
+
+sub root {
+ my $obj = shift;
+ croak("Safe root method now read-only") if @_;
+ return $obj->{Root};
+}
+
+
+sub mask {
+ my $obj = shift;
+ return $obj->{Mask} unless @_;
+ $obj->deny_only(@_);
+}
+
+# v1 compatibility methods
+sub trap { shift->deny(@_) }
+sub untrap { shift->permit(@_) }
+
+sub deny {
+ my $obj = shift;
+ $obj->{Mask} |= opset(@_);
+}
+sub deny_only {
+ my $obj = shift;
+ $obj->{Mask} = opset(@_);
+}
+
+sub permit {
+ my $obj = shift;
+ # XXX needs testing
+ $obj->{Mask} &= invert_opset opset(@_);
+}
+sub permit_only {
+ my $obj = shift;
+ $obj->{Mask} = invert_opset opset(@_);
+}
+
+
+sub dump_mask {
+ my $obj = shift;
+ print opset_to_hex($obj->{Mask}),"\n";
+}
+
+
+sub share {
+ my($obj, @vars) = @_;
+ $obj->share_from(scalar(caller), \@vars);
+}
+
+
+sub share_from {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $no_record = shift || 0;
+ my $root = $obj->root();
+ croak("vars not an array ref") unless ref $vars eq 'ARRAY';
+ no strict 'refs';
+ # Check that 'from' package actually exists
+ croak("Package \"$pkg\" does not exist")
+ unless keys %{"$pkg\::"};
+ my $arg;
+ foreach $arg (@$vars) {
+ # catch some $safe->share($var) errors:
+ my ($var, $type);
+ $type = $1 if ($var = $arg) =~ s/^(\W)//;
+ # warn "share_from $pkg $type $var";
+ for (1..2) { # assign twice to avoid any 'used once' warnings
+ *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
+ : ($type eq '&') ? \&{$pkg."::$var"}
+ : ($type eq '$') ? \${$pkg."::$var"}
+ : ($type eq '@') ? \@{$pkg."::$var"}
+ : ($type eq '%') ? \%{$pkg."::$var"}
+ : ($type eq '*') ? *{$pkg."::$var"}
+ : croak(qq(Can't share "$type$var" of unknown type));
+ }
+ }
+ $obj->share_record($pkg, $vars) unless $no_record or !$vars;
+}
+
+
+sub share_record {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ # Record shares using keys of $obj->{Shares}. See reinit.
+ @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+}
+
+
+sub share_redo {
+ my $obj = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ my($var, $pkg);
+ while(($var, $pkg) = each %$shares) {
+ # warn "share_redo $pkg\:: $var";
+ $obj->share_from($pkg, [ $var ], 1);
+ }
+}
+
+
+sub share_forget {
+ delete shift->{Shares};
+}
+
+
+sub varglob {
+ my ($obj, $var) = @_;
+ no strict 'refs';
+ return *{$obj->root()."::$var"};
+}
+
+sub _clean_stash {
+ my ($root, $saved_refs) = @_;
+ $saved_refs ||= [];
+ no strict 'refs';
+ foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
+ push @$saved_refs, \*{$root.$hook};
+ delete ${$root}{$hook};
+ }
+
+ for (grep /::$/, keys %$root) {
+ next if \%{$root.$_} eq \%$root;
+ _clean_stash($root.$_, $saved_refs);
+ }
+}
+
+sub reval {
+ my ($obj, $expr, $strict) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = lexless_anon_sub($root, $strict, $expr);
+ # propagate context
+ my $sg = sub_generation();
+ my @subret = (wantarray)
+ ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
+ : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+ _clean_stash($root.'::') if $sg != sub_generation();
+ $obj->wrap_code_refs_within(@subret);
+ return (wantarray) ? @subret : $subret[0];
+}
+
+
+sub wrap_code_refs_within {
+ my $obj = shift;
+
+ $obj->_find_code_refs('wrap_code_ref', @_);
+}
+
+
+sub _find_code_refs {
+ my $obj = shift;
+ my $visitor = shift;
+
+ for my $item (@_) {
+ my $reftype = $item && reftype $item
+ or next;
+ if ($reftype eq 'ARRAY') {
+ $obj->_find_code_refs($visitor, @$item);
+ }
+ elsif ($reftype eq 'HASH') {
+ $obj->_find_code_refs($visitor, values %$item);
+ }
+ # XXX GLOBs?
+ elsif ($reftype eq 'CODE') {
+ $item = $obj->$visitor($item);
+ }
+ }
+}
+
+
+sub wrap_code_ref {
+ my ($obj, $sub) = @_;
+
+ # wrap code ref $sub with _safe_call_sv so that, when called, the
+ # execution will happen with the compartment fully 'in effect'.
+
+ croak "Not a CODE reference"
+ if reftype $sub ne 'CODE';
+
+ my $ret = sub {
+ my @args = @_; # lexical to close over
+ my $sub_with_args = sub { $sub->(@args) };
+
+ my @subret;
+ my $error;
+ do {
+ local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
+ my $sg = sub_generation();
+ @subret = (wantarray)
+ ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
+ : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
+ $error = $@;
+ _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
+ };
+ if ($error) { # rethrow exception
+ $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
+ die $error;
+ }
+ return (wantarray) ? @subret : $subret[0];
+ };
+
+ return $ret;
+}
+
+
+sub rdo {
+ my ($obj, $file) = @_;
+ my $root = $obj->{Root};
+
+ my $sg = sub_generation();
+ my $evalsub = eval
+ sprintf('package %s; sub { @_ = (); do $file }', $root);
+ my @subret = (wantarray)
+ ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
+ : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+ _clean_stash($root.'::') if $sg != sub_generation();
+ $obj->wrap_code_refs_within(@subret);
+ return (wantarray) ? @subret : $subret[0];
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Safe - Compile and execute code in restricted compartments
+
+=head1 SYNOPSIS
+
+ use Safe;
+
+ $compartment = new Safe;
+
+ $compartment->permit(qw(time sort :browse));
+
+ $result = $compartment->reval($unsafe_code);
+
+=head1 DESCRIPTION
+
+The Safe extension module allows the creation of compartments
+in which perl code can be evaluated. Each compartment has
+
+=over 8
+
+=item a new namespace
+
+The "root" of the namespace (i.e. "main::") is changed to a
+different package and code evaluated in the compartment cannot
+refer to variables outside this namespace, even with run-time
+glob lookups and other tricks.
+
+Code which is compiled outside the compartment can choose to place
+variables into (or I<share> variables with) the compartment's namespace
+and only that data will be visible to code evaluated in the
+compartment.
+
+By default, the only variables shared with compartments are the
+"underscore" variables $_ and @_ (and, technically, the less frequently
+used %_, the _ filehandle and so on). This is because otherwise perl
+operators which default to $_ will not work and neither will the
+assignment of arguments to @_ on subroutine entry.
+
+=item an operator mask
+
+Each compartment has an associated "operator mask". Recall that
+perl code is compiled into an internal format before execution.
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+Code evaluated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaluate code in a
+compartment which contains a masked operator will cause the
+compilation to fail with an error. The code will not be executed.
+
+The default operator mask for a newly created compartment is
+the ':default' optag.
+
+It is important that you read the L<Opcode> module documentation
+for more information, especially for detailed definitions of opnames,
+optags and opsets.
+
+Since it is only at the compilation stage that the operator mask
+applies, controlled access to potentially unsafe operations can
+be achieved by having a handle to a wrapper subroutine (written
+outside the compartment) placed into the compartment. For example,
+
+ $cpt = new Safe;
+ sub wrapper {
+ # vet arguments and perform potentially unsafe operations
+ }
+ $cpt->share('&wrapper');
+
+=back
+
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head1 METHODS
+
+To create a new compartment, use
+
+ $cpt = new Safe;
+
+Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
+to use for the compartment (defaults to "Safe::Root0", incremented for
+each new compartment).
+
+Note that version 1.00 of the Safe module supported a second optional
+parameter, MASK. That functionality has been withdrawn pending deeper
+consideration. Use the permit and deny methods described below.
+
+The following methods can then be used on the compartment
+object returned by the above constructor. The object argument
+is implicit in each case.
+
+
+=head2 permit (OP, ...)
+
+Permit the listed operators to be used when compiling code in the
+compartment (in I<addition> to any operators already permitted).
+
+You can list opcodes by names, or use a tag name; see
+L<Opcode/"Predefined Opcode Tags">.
+
+=head2 permit_only (OP, ...)
+
+Permit I<only> the listed operators to be used when compiling code in
+the compartment (I<no> other operators are permitted).
+
+=head2 deny (OP, ...)
+
+Deny the listed operators from being used when compiling code in the
+compartment (other operators may still be permitted).
+
+=head2 deny_only (OP, ...)
+
+Deny I<only> the listed operators from being used when compiling code
+in the compartment (I<all> other operators will be permitted, so you probably
+don't want to use this method).
+
+=head2 trap (OP, ...)
+
+=head2 untrap (OP, ...)
+
+The trap and untrap methods are synonyms for deny and permit
+respectfully.
+
+=head2 share (NAME, ...)
+
+This shares the variable(s) in the argument list with the compartment.
+This is almost identical to exporting variables using the L<Exporter>
+module.
+
+Each NAME must be the B<name> of a non-lexical variable, typically
+with the leading type identifier included. A bareword is treated as a
+function name.
+
+Examples of legal names are '$foo' for a scalar, '@foo' for an
+array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
+for a glob (i.e. all symbol table entries associated with "foo",
+including scalar, array, hash, sub and filehandle).
+
+Each NAME is assumed to be in the calling package. See share_from
+for an alternative method (which C<share> uses).
+
+=head2 share_from (PACKAGE, ARRAYREF)
+
+This method is similar to share() but allows you to explicitly name the
+package that symbols should be shared from. The symbol names (including
+type characters) are supplied as an array reference.
+
+ $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
+
+Names can include package names, which are relative to the specified PACKAGE.
+So these two calls have the same effect:
+
+ $safe->share_from('Scalar::Util', [ 'reftype' ]);
+ $safe->share_from('main', [ 'Scalar::Util::reftype' ]);
+
+=head2 varglob (VARNAME)
+
+This returns a glob reference for the symbol table entry of VARNAME in
+the package of the compartment. VARNAME must be the B<name> of a
+variable without any leading type marker. For example:
+
+ ${$cpt->varglob('foo')} = "Hello world";
+
+has the same effect as:
+
+ $cpt = new Safe 'Root';
+ $Root::foo = "Hello world";
+
+but avoids the need to know $cpt's package name.
+
+
+=head2 reval (STRING, STRICT)
+
+This evaluates STRING as perl code inside the compartment.
+
+The code can only see the compartment's namespace (as returned by the
+B<root> method). The compartment's root package appears to be the
+C<main::> package to the code inside the compartment.
+
+Any attempt by the code in STRING to use an operator which is not permitted
+by the compartment will cause an error (at run-time of the main program
+but at compile-time for the code in STRING). The error is of the form
+"'%s' trapped by operation mask...".
+
+If an operation is trapped in this way, then the code in STRING will
+not be executed. If such a trapped operation occurs or any other
+compile-time or return error, then $@ is set to the error message, just
+as with an eval().
+
+If there is no error, then the method returns the value of the last
+expression evaluated, or a return statement may be used, just as with
+subroutines and B<eval()>. The context (list or scalar) is determined
+by the caller as usual.
+
+If the return value of reval() is (or contains) any code reference,
+those code references are wrapped to be themselves executed always
+in the compartment. See L</wrap_code_refs_within>.
+
+The formerly undocumented STRICT argument sets strictness: if true
+'use strict;' is used, otherwise it uses 'no strict;'. B<Note>: if
+STRICT is omitted 'no strict;' is the default.
+
+Some points to note:
+
+If the entereval op is permitted then the code can use eval "..." to
+'hide' code which might use denied ops. This is not a major problem
+since when the code tries to execute the eval it will fail because the
+opmask is still in effect. However this technique would allow clever,
+and possibly harmful, code to 'probe' the boundaries of what is
+possible.
+
+Any string eval which is executed by code executing in a compartment,
+or by code called from code executing in a compartment, will be eval'd
+in the namespace of the compartment. This is potentially a serious
+problem.
+
+Consider a function foo() in package pkg compiled outside a compartment
+but shared with it. Assume the compartment has a root package called
+'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
+normally, $pkg::foo will be set to 1. If foo() is called from the
+compartment (by whatever means) then instead of setting $pkg::foo, the
+eval will actually set $Root::pkg::foo.
+
+This can easily be demonstrated by using a module, such as the Socket
+module, which uses eval "..." as part of an AUTOLOAD function. You can
+'use' the module outside the compartment and share an (autoloaded)
+function with the compartment. If an autoload is triggered by code in
+the compartment, or by any code anywhere that is called by any means
+from the compartment, then the eval in the Socket module's AUTOLOAD
+function happens in the namespace of the compartment. Any variables
+created or used by the eval'd code are now under the control of
+the code in the compartment.
+
+A similar effect applies to I<all> runtime symbol lookups in code
+called from a compartment but not compiled within it.
+
+=head2 rdo (FILENAME)
+
+This evaluates the contents of file FILENAME inside the compartment.
+See above documentation on the B<reval> method for further details.
+
+=head2 root (NAMESPACE)
+
+This method returns the name of the package that is the root of the
+compartment's namespace.
+
+Note that this behaviour differs from version 1.00 of the Safe module
+where the root module could be used to change the namespace. That
+functionality has been withdrawn pending deeper consideration.
+
+=head2 mask (MASK)
+
+This is a get-or-set method for the compartment's operator mask.
+
+With no MASK argument present, it returns the current operator mask of
+the compartment.
+
+With the MASK argument present, it sets the operator mask for the
+compartment (equivalent to calling the deny_only method).
+
+=head2 wrap_code_ref (CODEREF)
+
+Returns a reference to an anonymous subroutine that, when executed, will call
+CODEREF with the Safe compartment 'in effect'. In other words, with the
+package namespace adjusted and the opmask enabled.
+
+Note that the opmask doesn't affect the already compiled code, it only affects
+any I<further> compilation that the already compiled code may try to perform.
+
+This is particularly useful when applied to code references returned from reval().
+
+(It also provides a kind of workaround for RT#60374: "Safe.pm sort {} bug with
+-Dusethreads". See L<http://rt.perl.org/rt3//Public/Bug/Display.html?id=60374>
+for I<much> more detail.)
+
+=head2 wrap_code_refs_within (...)
+
+Wraps any CODE references found within the arguments by replacing each with the
+result of calling L</wrap_code_ref> on the CODE reference. Any ARRAY or HASH
+references in the arguments are inspected recursively.
+
+Returns nothing.
+
+=head1 RISKS
+
+This section is just an outline of some of the things code in a compartment
+might do (intentionally or unintentionally) which can have an effect outside
+the compartment.
+
+=over 8
+
+=item Memory
+
+Consuming all (or nearly all) available memory.
+
+=item CPU
+
+Causing infinite loops etc.
+
+=item Snooping
+
+Copying private information out of your system. Even something as
+simple as your user name is of value to others. Much useful information
+could be gleaned from your environment variables for example.
+
+=item Signals
+
+Causing signals (especially SIGFPE and SIGALARM) to affect your process.
+
+Setting up a signal handler will need to be carefully considered
+and controlled. What mask is in effect when a signal handler
+gets called? If a user can get an imported function to get an
+exception and call the user's signal handler, does that user's
+restricted mask get re-instated before the handler is called?
+Does an imported handler get called with its original mask or
+the user's one?
+
+=item State Changes
+
+Ops such as chdir obviously effect the process as a whole and not just
+the code in the compartment. Ops such as rand and srand have a similar
+but more subtle effect.
+
+=back
+
+=head1 AUTHOR
+
+Originally designed and implemented by Malcolm Beattie.
+
+Reworked to use the Opcode module and other changes added by Tim Bunce.
+
+Currently maintained by the Perl 5 Porters, <perl5-porters@perl.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/SelectSaver.pm b/Master/tlpkg/tlperl/lib/SelectSaver.pm
new file mode 100644
index 00000000000..b67adff42bb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/SelectSaver.pm
@@ -0,0 +1,54 @@
+package SelectSaver;
+
+our $VERSION = '1.02';
+
+=head1 NAME
+
+SelectSaver - save and restore selected file handle
+
+=head1 SYNOPSIS
+
+ use SelectSaver;
+
+ {
+ my $saver = SelectSaver->new(FILEHANDLE);
+ # FILEHANDLE is selected
+ }
+ # previous handle is selected
+
+ {
+ my $saver = SelectSaver->new;
+ # new handle may be selected, or not
+ }
+ # previous handle is selected
+
+=head1 DESCRIPTION
+
+A C<SelectSaver> object contains a reference to the file handle that
+was selected when it was created. If its C<new> method gets an extra
+parameter, then that parameter is selected; otherwise, the selected
+file handle remains unchanged.
+
+When a C<SelectSaver> is destroyed, it re-selects the file handle
+that was selected when it was created.
+
+=cut
+
+require 5.000;
+use Carp;
+use Symbol;
+
+sub new {
+ @_ >= 1 && @_ <= 2 or croak 'usage: SelectSaver->new( [FILEHANDLE] )';
+ my $fh = select;
+ my $self = bless \$fh, $_[0];
+ select qualify($_[1], caller) if @_ > 1;
+ $self;
+}
+
+sub DESTROY {
+ my $self = $_[0];
+ select $$self;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/SelfLoader.pm b/Master/tlpkg/tlperl/lib/SelfLoader.pm
new file mode 100644
index 00000000000..047f7768e89
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/SelfLoader.pm
@@ -0,0 +1,435 @@
+package SelfLoader;
+use 5.008;
+use strict;
+our $VERSION = "1.17";
+
+# The following bit of eval-magic is necessary to make this work on
+# perls < 5.009005.
+use vars qw/$AttrList/;
+BEGIN {
+ if ($] > 5.009004) {
+ eval <<'NEWERPERL';
+use 5.009005; # due to new regexp features
+# allow checking for valid ': attrlist' attachments
+# see also AutoSplit
+$AttrList = qr{
+ \s* : \s*
+ (?:
+ # one attribute
+ (?> # no backtrack
+ (?! \d) \w+
+ (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
+ )
+ (?: \s* : \s* | \s+ (?! :) )
+ )*
+}x;
+
+NEWERPERL
+ }
+ else {
+ eval <<'OLDERPERL';
+# allow checking for valid ': attrlist' attachments
+# (we use 'our' rather than 'my' here, due to the rather complex and buggy
+# behaviour of lexicals with qr// and (??{$lex}) )
+our $nested;
+$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
+our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
+$AttrList = qr{ \s* : \s* (?: $one_attr )* }x;
+OLDERPERL
+ }
+}
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(AUTOLOAD);
+sub Version {$VERSION}
+sub DEBUG () { 0 }
+
+my %Cache; # private cache for all SelfLoader's client packages
+
+# in croak and carp, protect $@ from "require Carp;" RT #40216
+
+sub croak { { local $@; require Carp; } goto &Carp::croak }
+sub carp { { local $@; require Carp; } goto &Carp::carp }
+
+AUTOLOAD {
+ our $AUTOLOAD;
+ print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if DEBUG;
+ my $SL_code = $Cache{$AUTOLOAD};
+ my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@
+ unless ($SL_code) {
+ # Maybe this pack had stubs before __DATA__, and never initialized.
+ # Or, this maybe an automatic DESTROY method call when none exists.
+ $AUTOLOAD =~ m/^(.*)::/;
+ SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"};
+ $SL_code = $Cache{$AUTOLOAD};
+ $SL_code = "sub $AUTOLOAD { }"
+ if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/);
+ croak "Undefined subroutine $AUTOLOAD" unless $SL_code;
+ }
+ print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if DEBUG;
+
+ {
+ no strict;
+ eval $SL_code;
+ }
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ croak $@;
+ }
+ $@ = $save;
+ defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
+ delete $Cache{$AUTOLOAD};
+ goto &$AUTOLOAD
+}
+
+sub load_stubs { shift->_load_stubs((caller)[0]) }
+
+sub _load_stubs {
+ # $endlines is used by Devel::SelfStubber to capture lines after __END__
+ my($self, $callpack, $endlines) = @_;
+ no strict "refs";
+ my $fh = \*{"${callpack}::DATA"};
+ use strict;
+ my $currpack = $callpack;
+ my($line,$name,@lines, @stubs, $protoype);
+
+ print STDERR "SelfLoader::load_stubs($callpack)\n" if DEBUG;
+ croak("$callpack doesn't contain an __DATA__ token")
+ unless defined fileno($fh);
+ # Protect: fork() shares the file pointer between the parent and the kid
+ if(sysseek($fh, tell($fh), 0)) {
+ open my $nfh, '<&', $fh or croak "reopen: $!";# dup() the fd
+ close $fh or die "close: $!"; # autocloses, but be paranoid
+ open $fh, '<&', $nfh or croak "reopen2: $!"; # dup() the fd "back"
+ close $nfh or die "close after reopen: $!"; # autocloses, but be paranoid
+ }
+ $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
+
+ local($/) = "\n";
+ while(defined($line = <$fh>) and $line !~ m/^__END__/) {
+ if ($line =~ m/^\s*sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$AttrList)?)/) {
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ $protoype = $2;
+ @lines = ($line);
+ if (index($1,'::') == -1) { # simple sub name
+ $name = "${currpack}::$1";
+ } else { # sub name with package
+ $name = $1;
+ $name =~ m/^(.*)::/;
+ if (defined(&{"${1}::AUTOLOAD"})) {
+ \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
+ die 'SelfLoader Error: attempt to specify Selfloading',
+ " sub $name in non-selfloading module $1";
+ } else {
+ $self->export($1,'AUTOLOAD');
+ }
+ }
+ } elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ $self->_package_defined($line);
+ $name = '';
+ @lines = ();
+ $currpack = $1;
+ $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
+ if (defined(&{"${1}::AUTOLOAD"})) {
+ \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
+ die 'SelfLoader Error: attempt to specify Selfloading',
+ " package $currpack which already has AUTOLOAD";
+ } else {
+ $self->export($currpack,'AUTOLOAD');
+ }
+ } else {
+ push(@lines,$line);
+ }
+ }
+ if (defined($line) && $line =~ /^__END__/) { # __END__
+ unless ($line =~ /^__END__\s*DATA/) {
+ if ($endlines) {
+ # Devel::SelfStubber would like us to capture the lines after
+ # __END__ so it can write out the entire file
+ @$endlines = <$fh>;
+ }
+ close($fh);
+ }
+ }
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ no strict;
+ eval join('', @stubs) if @stubs;
+}
+
+
+sub _add_to_cache {
+ my($self,$fullname,$pack,$lines, $protoype) = @_;
+ return () unless $fullname;
+ carp("Redefining sub $fullname")
+ if exists $Cache{$fullname};
+ $Cache{$fullname} = join('', "\n\#line 1 \"sub $fullname\"\npackage $pack; ", @$lines);
+ #$Cache{$fullname} = join('', "package $pack; ",@$lines);
+ print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if DEBUG;
+ # return stub to be eval'd
+ defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;"
+}
+
+sub _package_defined {}
+
+1;
+__END__
+
+=head1 NAME
+
+SelfLoader - load functions only on demand
+
+=head1 SYNOPSIS
+
+ package FOOBAR;
+ use SelfLoader;
+
+ ... (initializing code)
+
+ __DATA__
+ sub {....
+
+
+=head1 DESCRIPTION
+
+This module tells its users that functions in the FOOBAR package are to be
+autoloaded from after the C<__DATA__> token. See also
+L<perlsub/"Autoloading">.
+
+=head2 The __DATA__ token
+
+The C<__DATA__> token tells the perl compiler that the perl code
+for compilation is finished. Everything after the C<__DATA__> token
+is available for reading via the filehandle FOOBAR::DATA,
+where FOOBAR is the name of the current package when the C<__DATA__>
+token is reached. This works just the same as C<__END__> does in
+package 'main', but for other modules data after C<__END__> is not
+automatically retrievable, whereas data after C<__DATA__> is.
+The C<__DATA__> token is not recognized in versions of perl prior to
+5.001m.
+
+Note that it is possible to have C<__DATA__> tokens in the same package
+in multiple files, and that the last C<__DATA__> token in a given
+package that is encountered by the compiler is the one accessible
+by the filehandle. This also applies to C<__END__> and main, i.e. if
+the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd)
+by that program has a 'package main;' declaration followed by an 'C<__DATA__>',
+then the C<DATA> filehandle is set to access the data after the C<__DATA__>
+in the module, _not_ the data after the C<__END__> token in the 'main'
+program, since the compiler encounters the 'require'd file later.
+
+=head2 SelfLoader autoloading
+
+The B<SelfLoader> works by the user placing the C<__DATA__>
+token I<after> perl code which needs to be compiled and
+run at 'require' time, but I<before> subroutine declarations
+that can be loaded in later - usually because they may never
+be called.
+
+The B<SelfLoader> will read from the FOOBAR::DATA filehandle to
+load in the data after C<__DATA__>, and load in any subroutine
+when it is called. The costs are the one-time parsing of the
+data after C<__DATA__>, and a load delay for the _first_
+call of any autoloaded function. The benefits (hopefully)
+are a speeded up compilation phase, with no need to load
+functions which are never used.
+
+The B<SelfLoader> will stop reading from C<__DATA__> if
+it encounters the C<__END__> token - just as you would expect.
+If the C<__END__> token is present, and is followed by the
+token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA
+filehandle open on the line after that token.
+
+The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the
+package using the B<SelfLoader>, and this loads the called
+subroutine when it is first called.
+
+There is no advantage to putting subroutines which will _always_
+be called after the C<__DATA__> token.
+
+=head2 Autoloading and package lexicals
+
+A 'my $pack_lexical' statement makes the variable $pack_lexical
+local _only_ to the file up to the C<__DATA__> token. Subroutines
+declared elsewhere _cannot_ see these types of variables,
+just as if you declared subroutines in the package but in another
+file, they cannot see these variables.
+
+So specifically, autoloaded functions cannot see package
+lexicals (this applies to both the B<SelfLoader> and the Autoloader).
+The C<vars> pragma provides an alternative to defining package-level
+globals that will be visible to autoloaded routines. See the documentation
+on B<vars> in the pragma section of L<perlmod>.
+
+=head2 SelfLoader and AutoLoader
+
+The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader'
+to 'use SelfLoader' (though note that the B<SelfLoader> exports
+the AUTOLOAD function - but if you have your own AUTOLOAD and
+are using the AutoLoader too, you probably know what you're doing),
+and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m
+or later to use this (version 5.001 with all patches up to patch m).
+
+There is no need to inherit from the B<SelfLoader>.
+
+The B<SelfLoader> works similarly to the AutoLoader, but picks up the
+subs from after the C<__DATA__> instead of in the 'lib/auto' directory.
+There is a maintenance gain in not needing to run AutoSplit on the module
+at installation, and a runtime gain in not needing to keep opening and
+closing files to load subs. There is a runtime loss in needing
+to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and
+another view of these distinctions can be found in that module's
+documentation.
+
+=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
+
+This section is only relevant if you want to use
+the C<FOOBAR::DATA> together with the B<SelfLoader>.
+
+Data after the C<__DATA__> token in a module is read using the
+FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end
+of the C<__DATA__> section if followed by the token DATA - this is supported
+by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an
+C<__END__> followed by a DATA is found, with the filehandle positioned at
+the start of the line after the C<__END__> token. If no C<__END__> token is
+present, or an C<__END__> token with no DATA token on the same line, then
+the filehandle is closed.
+
+The B<SelfLoader> reads from wherever the current
+position of the C<FOOBAR::DATA> filehandle is, until the
+EOF or C<__END__>. This means that if you want to use
+that filehandle (and ONLY if you want to), you should either
+
+1. Put all your subroutine declarations immediately after
+the C<__DATA__> token and put your own data after those
+declarations, using the C<__END__> token to mark the end
+of subroutine declarations. You must also ensure that the B<SelfLoader>
+reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a
+function which is selfloaded;
+
+or
+
+2. You should read the C<FOOBAR::DATA> filehandle first, leaving
+the handle open and positioned at the first line of subroutine
+declarations.
+
+You could conceivably do both.
+
+=head2 Classes and inherited methods.
+
+For modules which are not classes, this section is not relevant.
+This section is only relevant if you have methods which could
+be inherited.
+
+A subroutine stub (or forward declaration) looks like
+
+ sub stub;
+
+i.e. it is a subroutine declaration without the body of the
+subroutine. For modules which are not classes, there is no real
+need for stubs as far as autoloading is concerned.
+
+For modules which ARE classes, and need to handle inherited methods,
+stubs are needed to ensure that the method inheritance mechanism works
+properly. You can load the stubs into the module at 'require' time, by
+adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do
+this.
+
+The alternative is to put the stubs in before the C<__DATA__> token BEFORE
+releasing the module, and for this purpose the C<Devel::SelfStubber>
+module is available. However this does require the extra step of ensuring
+that the stubs are in the module. If this is done I strongly recommend
+that this is done BEFORE releasing the module - it should NOT be done
+at install time in general.
+
+=head1 Multiple packages and fully qualified subroutine names
+
+Subroutines in multiple packages within the same file are supported - but you
+should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
+every package which requires it. This is done automatically by the
+B<SelfLoader> when it first loads the subs into the cache, but you should
+really specify it in the initialization before the C<__DATA__> by putting
+a 'use SelfLoader' statement in each package.
+
+Fully qualified subroutine names are also supported. For example,
+
+ __DATA__
+ sub foo::bar {23}
+ package baz;
+ sub dob {32}
+
+will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
+will ensure that the packages 'foo' and 'baz' correctly have the
+B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
+parsed.
+
+=head1 AUTHOR
+
+C<SelfLoader> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since the first release
+of perl5. It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core:
+
+ Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others
+
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program in the file named "Copying". If not, write to the
+ Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307, USA or visit their web page on the internet at
+ http://www.gnu.org/copyleft/gpl.html.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Shell.pm b/Master/tlpkg/tlperl/lib/Shell.pm
new file mode 100644
index 00000000000..72c7ec21376
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Shell.pm
@@ -0,0 +1,270 @@
+package Shell;
+use 5.006_001;
+use strict;
+use warnings;
+use File::Spec::Functions;
+
+our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
+
+$VERSION = '0.72_01';
+$VERSION = eval $VERSION;
+
+sub new { bless \my $foo, shift }
+sub DESTROY { }
+
+sub import {
+ my $self = shift;
+ my ($callpack, $callfile, $callline) = caller;
+ my @EXPORT;
+ if (@_) {
+ @EXPORT = @_;
+ } else {
+ @EXPORT = 'AUTOLOAD';
+ }
+ foreach my $sym (@EXPORT) {
+ no strict 'refs';
+ *{"${callpack}::$sym"} = \&{"Shell::$sym"};
+ }
+}
+
+# NOTE: this is used to enable constant folding in
+# expressions like (OS eq 'MSWin32') and
+# (OS eq 'os2') just like it happened in 0.6 version
+# which used eval "string" to install subs on the fly.
+use constant OS => $^O;
+
+=begin private
+
+=item B<_make_cmd>
+
+ $sub = _make_cmd($cmd);
+ $sub = $shell->_make_cmd($cmd);
+
+Creates a closure which invokes the system command C<$cmd>.
+
+=end private
+
+=cut
+
+sub _make_cmd {
+ shift if ref $_[0] && $_[0]->isa( 'Shell' );
+ my $cmd = shift;
+ my $null = File::Spec::Functions::devnull();
+ $Shell::capture_stderr ||= 0;
+ # closing over $^O, $cmd, and $null
+ return sub {
+ shift if ref $_[0] && $_[0]->isa( 'Shell' );
+ if (@_ < 1) {
+ $Shell::capture_stderr == 1 ? `$cmd 2>&1` :
+ $Shell::capture_stderr == -1 ? `$cmd 2>$null` :
+ `$cmd`;
+ } elsif (OS eq 'os2') {
+ local(*SAVEOUT, *READ, *WRITE);
+
+ open SAVEOUT, '>&STDOUT' or die;
+ pipe READ, WRITE or die;
+ open STDOUT, '>&WRITE' or die;
+ close WRITE;
+
+ my $pid = system(1, $cmd, @_);
+ die "Can't execute $cmd: $!\n" if $pid < 0;
+
+ open STDOUT, '>&SAVEOUT' or die;
+ close SAVEOUT;
+
+ if (wantarray) {
+ my @ret = <READ>;
+ close READ;
+ waitpid $pid, 0;
+ @ret;
+ } else {
+ local($/) = undef;
+ my $ret = <READ>;
+ close READ;
+ waitpid $pid, 0;
+ $ret;
+ }
+ } else {
+ my $a;
+ my @arr = @_;
+ unless( $Shell::raw ){
+ if (OS eq 'MSWin32') {
+ # XXX this special-casing should not be needed
+ # if we do quoting right on Windows. :-(
+ #
+ # First, escape all quotes. Cover the case where we
+ # want to pass along a quote preceded by a backslash
+ # (i.e., C<"param \""" end">).
+ # Ugly, yup? You know, windoze.
+ # Enclose in quotes only the parameters that need it:
+ # try this: c:> dir "/w"
+ # and this: c:> dir /w
+ for (@arr) {
+ s/"/\\"/g;
+ s/\\\\"/\\\\"""/g;
+ $_ = qq["$_"] if /\s/;
+ }
+ } else {
+ for (@arr) {
+ s/(['\\])/\\$1/g;
+ $_ = $_;
+ }
+ }
+ }
+ push @arr, '2>&1' if $Shell::capture_stderr == 1;
+ push @arr, '2>$null' if $Shell::capture_stderr == -1;
+ open(SUBPROC, join(' ', $cmd, @arr, '|'))
+ or die "Can't exec $cmd: $!\n";
+ if (wantarray) {
+ my @ret = <SUBPROC>;
+ close SUBPROC; # XXX Oughta use a destructor.
+ @ret;
+ } else {
+ local($/) = undef;
+ my $ret = <SUBPROC>;
+ close SUBPROC;
+ $ret;
+ }
+ }
+ };
+ }
+
+sub AUTOLOAD {
+ shift if ref $_[0] && $_[0]->isa( 'Shell' );
+ my $cmd = $AUTOLOAD;
+ $cmd =~ s/^.*:://;
+ no strict 'refs';
+ *$AUTOLOAD = _make_cmd($cmd);
+ goto &$AUTOLOAD;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Shell - run shell commands transparently within perl
+
+=head1 SYNOPSIS
+
+ use Shell qw(cat ps cp);
+ $passwd = cat('</etc/passwd');
+ @pslines = ps('-ww'),
+ cp("/etc/passwd", "/tmp/passwd");
+
+ # object oriented
+ my $sh = Shell->new;
+ print $sh->ls('-l');
+
+=head1 DESCRIPTION
+
+=head2 Caveats
+
+This package is included as a show case, illustrating a few Perl features.
+It shouldn't be used for production programs. Although it does provide a
+simple interface for obtaining the standard output of arbitrary commands,
+there may be better ways of achieving what you need.
+
+Running shell commands while obtaining standard output can be done with the
+C<qx/STRING/> operator, or by calling C<open> with a filename expression that
+ends with C<|>, giving you the option to process one line at a time.
+If you don't need to process standard output at all, you might use C<system>
+(in preference of doing a print with the collected standard output).
+
+Since Shell.pm and all of the aforementioned techniques use your system's
+shell to call some local command, none of them is portable across different
+systems. Note, however, that there are several built in functions and
+library packages providing portable implementations of functions operating
+on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>,
+C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
+
+Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
+namespace of the importing package. Calling C<foo> with arguments C<arg1>,
+C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the
+function name and the arguments are joined with a blank. (See the subsection
+on Escaping magic characters.) Since the result is essentially a command
+line to be passed to the shell, your notion of arguments to the Perl
+function is not necessarily identical to what the shell treats as a
+command line token, to be passed as an individual argument to the program.
+Furthermore, note that this implies that C<foo> is callable by file name
+only, which frequently depends on the setting of the program's environment.
+
+Creating a Shell object gives you the opportunity to call any command
+in the usual OO notation without requiring you to announce it in the
+C<use Shell> statement. Don't assume any additional semantics being
+associated with a Shell object: in no way is it similar to a shell
+process with its environment or current working directory or any
+other setting.
+
+=head2 Escaping Magic Characters
+
+It is, in general, impossible to take care of quoting the shell's
+magic characters. For some obscure reason, however, Shell.pm quotes
+apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
+quotes (C<">) on Windows.
+
+=head2 Configuration
+
+If you set $Shell::capture_stderr to 1, the module will attempt to
+capture the standard error output of the process as well. This is
+done by adding C<2E<gt>&1> to the command line, so don't try this on
+a system not supporting this redirection.
+
+Setting $Shell::capture_stderr to -1 will send standard error to the
+bit bucket (i.e., the equivalent of adding C<2E<gt>/dev/null> to the
+command line). The same caveat regarding redirection applies.
+
+If you set $Shell::raw to true no quoting whatsoever is done.
+
+=head1 BUGS
+
+Quoting should be off by default.
+
+It isn't possible to call shell built in commands, but it can be
+done by using a workaround, e.g. shell( '-c', 'set' ).
+
+Capturing standard error does not work on some systems (e.g. VMS).
+
+=head1 AUTHOR
+
+ Date: Thu, 22 Sep 94 16:18:16 -0700
+ Message-Id: <9409222318.AA17072@scalpel.netlabs.com>
+ To: perl5-porters@isu.edu
+ From: Larry Wall <lwall@scalpel.netlabs.com>
+ Subject: a new module I just wrote
+
+Here's one that'll whack your mind a little out.
+
+ #!/usr/bin/perl
+
+ use Shell;
+
+ $foo = echo("howdy", "<funny>", "world");
+ print $foo;
+
+ $passwd = cat("</etc/passwd");
+ print $passwd;
+
+ sub ps;
+ print ps -ww;
+
+ cp("/etc/passwd", "/etc/passwd.orig");
+
+That's maybe too gonzo. It actually exports an AUTOLOAD to the current
+package (and uncovered a bug in Beta 3, by the way). Maybe the usual
+usage should be
+
+ use Shell qw(echo cat ps cp);
+
+Larry Wall
+
+Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>.
+
+Changes for OO syntax and bug fixes by Casey West <casey@geeknest.com>.
+
+C<$Shell::raw> and pod rewrite by Wolfgang Laun.
+
+Rewritten to use closures rather than C<eval "string"> by Adriano Ferreira.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Socket.pm b/Master/tlpkg/tlperl/lib/Socket.pm
new file mode 100644
index 00000000000..51bf28a333c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Socket.pm
@@ -0,0 +1,436 @@
+package Socket;
+
+our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+$VERSION = "1.87_01";
+
+=head1 NAME
+
+Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa, inet_pton, inet_ntop - load the C socket.h defines and structure manipulators
+
+=head1 SYNOPSIS
+
+ use Socket;
+
+ $proto = getprotobyname('udp');
+ socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto);
+ $iaddr = gethostbyname('hishost.com');
+ $port = getservbyname('time', 'udp');
+ $sin = sockaddr_in($port, $iaddr);
+ send(Socket_Handle, 0, 0, $sin);
+
+ $proto = getprotobyname('tcp');
+ socket(Socket_Handle, PF_INET, SOCK_STREAM, $proto);
+ $port = getservbyname('smtp', 'tcp');
+ $sin = sockaddr_in($port,inet_aton("127.1"));
+ $sin = sockaddr_in(7,inet_aton("localhost"));
+ $sin = sockaddr_in(7,INADDR_LOOPBACK);
+ connect(Socket_Handle,$sin);
+
+ ($port, $iaddr) = sockaddr_in(getpeername(Socket_Handle));
+ $peer_host = gethostbyaddr($iaddr, AF_INET);
+ $peer_addr = inet_ntoa($iaddr);
+
+ $proto = getprotobyname('tcp');
+ socket(Socket_Handle, PF_UNIX, SOCK_STREAM, $proto);
+ unlink('/var/run/usock');
+ $sun = sockaddr_un('/var/run/usock');
+ connect(Socket_Handle,$sun);
+
+=head1 DESCRIPTION
+
+This module is just a translation of the C F<socket.h> file.
+Unlike the old mechanism of requiring a translated F<socket.ph>
+file, this uses the B<h2xs> program (see the Perl source distribution)
+and your native C compiler. This means that it has a
+far more likely chance of getting the numbers right. This includes
+all of the commonly used pound-defines like AF_INET, SOCK_STREAM, etc.
+
+Also, some common socket "newline" constants are provided: the
+constants C<CR>, C<LF>, and C<CRLF>, as well as C<$CR>, C<$LF>, and
+C<$CRLF>, which map to C<\015>, C<\012>, and C<\015\012>. If you do
+not want to use the literal characters in your programs, then use
+the constants provided here. They are not exported by default, but can
+be imported individually, and with the C<:crlf> export tag:
+
+ use Socket qw(:DEFAULT :crlf);
+
+In addition, some structure manipulation functions are available:
+
+=over 4
+
+=item inet_aton HOSTNAME
+
+Takes a string giving the name of a host, and translates that to an
+opaque string (if programming in C, struct in_addr). Takes arguments
+of both the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name
+cannot be resolved, returns undef. For multi-homed hosts (hosts with
+more than one address), the first address found is returned.
+
+For portability do not assume that the result of inet_aton() is 32
+bits wide, in other words, that it would contain only the IPv4 address
+in network order.
+
+=item inet_ntoa IP_ADDRESS
+
+Takes a string (an opaque string as returned by inet_aton(),
+or a v-string representing the four octets of the IPv4 address in
+network order) and translates it into a string of the form 'd.d.d.d'
+where the 'd's are numbers less than 256 (the normal human-readable
+four dotted number notation for Internet addresses).
+
+=item INADDR_ANY
+
+Note: does not return a number, but a packed string.
+
+Returns the 4-byte wildcard ip address which specifies any
+of the hosts ip addresses. (A particular machine can have
+more than one ip address, each address corresponding to
+a particular network interface. This wildcard address
+allows you to bind to all of them simultaneously.)
+Normally equivalent to inet_aton('0.0.0.0').
+
+=item INADDR_BROADCAST
+
+Note: does not return a number, but a packed string.
+
+Returns the 4-byte 'this-lan' ip broadcast address.
+This can be useful for some protocols to solicit information
+from all servers on the same LAN cable.
+Normally equivalent to inet_aton('255.255.255.255').
+
+=item INADDR_LOOPBACK
+
+Note - does not return a number.
+
+Returns the 4-byte loopback address. Normally equivalent
+to inet_aton('localhost').
+
+=item INADDR_NONE
+
+Note - does not return a number.
+
+Returns the 4-byte 'invalid' ip address. Normally equivalent
+to inet_aton('255.255.255.255').
+
+=item sockaddr_family SOCKADDR
+
+Takes a sockaddr structure (as returned by pack_sockaddr_in(),
+pack_sockaddr_un() or the perl builtin functions getsockname() and
+getpeername()) and returns the address family tag. It will match the
+constant AF_INET for a sockaddr_in and AF_UNIX for a sockaddr_un. It
+can be used to figure out what unpacker to use for a sockaddr of
+unknown type.
+
+=item sockaddr_in PORT, ADDRESS
+
+=item sockaddr_in SOCKADDR_IN
+
+In a list context, unpacks its SOCKADDR_IN argument and returns an array
+consisting of (PORT, ADDRESS). In a scalar context, packs its (PORT,
+ADDRESS) arguments as a SOCKADDR_IN and returns it. If this is confusing,
+use pack_sockaddr_in() and unpack_sockaddr_in() explicitly.
+
+=item pack_sockaddr_in PORT, IP_ADDRESS
+
+Takes two arguments, a port number and an opaque string, IP_ADDRESS
+(as returned by inet_aton(), or a v-string). Returns the sockaddr_in
+structure with those arguments packed in with AF_INET filled in. For
+Internet domain sockets, this structure is normally what you need for
+the arguments in bind(), connect(), and send(), and is also returned
+by getpeername(), getsockname() and recv().
+
+=item unpack_sockaddr_in SOCKADDR_IN
+
+Takes a sockaddr_in structure (as returned by pack_sockaddr_in()) and
+returns an array of two elements: the port and an opaque string
+representing the IP address (you can use inet_ntoa() to convert the
+address to the four-dotted numeric format). Will croak if the
+structure does not have AF_INET in the right place.
+
+=item sockaddr_un PATHNAME
+
+=item sockaddr_un SOCKADDR_UN
+
+In a list context, unpacks its SOCKADDR_UN argument and returns an array
+consisting of (PATHNAME). In a scalar context, packs its PATHNAME
+arguments as a SOCKADDR_UN and returns it. If this is confusing, use
+pack_sockaddr_un() and unpack_sockaddr_un() explicitly.
+These are only supported if your system has E<lt>F<sys/un.h>E<gt>.
+
+=item pack_sockaddr_un PATH
+
+Takes one argument, a pathname. Returns the sockaddr_un structure with
+that path packed in with AF_UNIX filled in. For unix domain sockets, this
+structure is normally what you need for the arguments in bind(),
+connect(), and send(), and is also returned by getpeername(),
+getsockname() and recv().
+
+=item unpack_sockaddr_un SOCKADDR_UN
+
+Takes a sockaddr_un structure (as returned by pack_sockaddr_un())
+and returns the pathname. Will croak if the structure does not
+have AF_UNIX in the right place.
+
+=item inet_pton ADDRESS_FAMILY, HOSTNAME
+
+Takes an address family, either AF_INET or AF_INET6, and a string giving
+the name of a host, and translates that to an opaque string
+(if programming in C, struct in_addr or struct in6_addr depending on the
+address family passed in). The host string may be a string hostname, such
+as 'www.perl.org', or an IP address. If using an IP address, the type of
+IP address must be consistant with the address family passed into the function.
+
+This function is not exported by default.
+
+=item inet_ntop ADDRESS_FAMILY, IP_ADDRESS
+
+Takes an address family, either AF_INET or AF_INET6, and a string
+(an opaque string as returned by inet_aton() or inet_pton()) and
+translates it to an IPv4 or IPv6 address string.
+
+This function is not exported by default.
+
+=back
+
+=cut
+
+use Carp;
+use warnings::register;
+
+require Exporter;
+use XSLoader ();
+@ISA = qw(Exporter);
+@EXPORT = qw(
+ inet_aton inet_ntoa
+ sockaddr_family
+ pack_sockaddr_in unpack_sockaddr_in
+ pack_sockaddr_un unpack_sockaddr_un
+ sockaddr_in sockaddr_un
+ INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ AF_802
+ AF_AAL
+ AF_APPLETALK
+ AF_CCITT
+ AF_CHAOS
+ AF_CTF
+ AF_DATAKIT
+ AF_DECnet
+ AF_DLI
+ AF_ECMA
+ AF_GOSIP
+ AF_HYLINK
+ AF_IMPLINK
+ AF_INET
+ AF_INET6
+ AF_ISO
+ AF_KEY
+ AF_LAST
+ AF_LAT
+ AF_LINK
+ AF_MAX
+ AF_NBS
+ AF_NIT
+ AF_NS
+ AF_OSI
+ AF_OSINET
+ AF_PUP
+ AF_ROUTE
+ AF_SNA
+ AF_UNIX
+ AF_UNSPEC
+ AF_USER
+ AF_WAN
+ AF_X25
+ IOV_MAX
+ IP_OPTIONS
+ IP_HDRINCL
+ IP_TOS
+ IP_TTL
+ IP_RECVOPTS
+ IP_RECVRETOPTS
+ IP_RETOPTS
+ MSG_BCAST
+ MSG_BTAG
+ MSG_CTLFLAGS
+ MSG_CTLIGNORE
+ MSG_CTRUNC
+ MSG_DONTROUTE
+ MSG_DONTWAIT
+ MSG_EOF
+ MSG_EOR
+ MSG_ERRQUEUE
+ MSG_ETAG
+ MSG_FIN
+ MSG_MAXIOVLEN
+ MSG_MCAST
+ MSG_NOSIGNAL
+ MSG_OOB
+ MSG_PEEK
+ MSG_PROXY
+ MSG_RST
+ MSG_SYN
+ MSG_TRUNC
+ MSG_URG
+ MSG_WAITALL
+ MSG_WIRE
+ PF_802
+ PF_AAL
+ PF_APPLETALK
+ PF_CCITT
+ PF_CHAOS
+ PF_CTF
+ PF_DATAKIT
+ PF_DECnet
+ PF_DLI
+ PF_ECMA
+ PF_GOSIP
+ PF_HYLINK
+ PF_IMPLINK
+ PF_INET
+ PF_INET6
+ PF_ISO
+ PF_KEY
+ PF_LAST
+ PF_LAT
+ PF_LINK
+ PF_MAX
+ PF_NBS
+ PF_NIT
+ PF_NS
+ PF_OSI
+ PF_OSINET
+ PF_PUP
+ PF_ROUTE
+ PF_SNA
+ PF_UNIX
+ PF_UNSPEC
+ PF_USER
+ PF_WAN
+ PF_X25
+ SCM_CONNECT
+ SCM_CREDENTIALS
+ SCM_CREDS
+ SCM_RIGHTS
+ SCM_TIMESTAMP
+ SHUT_RD
+ SHUT_RDWR
+ SHUT_WR
+ SOCK_DGRAM
+ SOCK_RAW
+ SOCK_RDM
+ SOCK_SEQPACKET
+ SOCK_STREAM
+ SOL_SOCKET
+ SOMAXCONN
+ SO_ACCEPTCONN
+ SO_ATTACH_FILTER
+ SO_BACKLOG
+ SO_BROADCAST
+ SO_CHAMELEON
+ SO_DEBUG
+ SO_DETACH_FILTER
+ SO_DGRAM_ERRIND
+ SO_DONTLINGER
+ SO_DONTROUTE
+ SO_ERROR
+ SO_FAMILY
+ SO_KEEPALIVE
+ SO_LINGER
+ SO_OOBINLINE
+ SO_PASSCRED
+ SO_PASSIFNAME
+ SO_PEERCRED
+ SO_PROTOCOL
+ SO_PROTOTYPE
+ SO_RCVBUF
+ SO_RCVLOWAT
+ SO_RCVTIMEO
+ SO_REUSEADDR
+ SO_REUSEPORT
+ SO_SECURITY_AUTHENTICATION
+ SO_SECURITY_ENCRYPTION_NETWORK
+ SO_SECURITY_ENCRYPTION_TRANSPORT
+ SO_SNDBUF
+ SO_SNDLOWAT
+ SO_SNDTIMEO
+ SO_STATE
+ SO_TYPE
+ SO_USELOOPBACK
+ SO_XOPEN
+ SO_XSE
+ UIO_MAXIOV
+);
+
+@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF
+
+ inet_pton
+ inet_ntop
+
+ IPPROTO_IP
+ IPPROTO_IPV6
+ IPPROTO_RAW
+ IPPROTO_ICMP
+ IPPROTO_TCP
+ IPPROTO_UDP
+
+ TCP_KEEPALIVE
+ TCP_MAXRT
+ TCP_MAXSEG
+ TCP_NODELAY
+ TCP_STDURG);
+
+%EXPORT_TAGS = (
+ crlf => [qw(CR LF CRLF $CR $LF $CRLF)],
+ all => [@EXPORT, @EXPORT_OK],
+);
+
+BEGIN {
+ sub CR () {"\015"}
+ sub LF () {"\012"}
+ sub CRLF () {"\015\012"}
+}
+
+*CR = \CR();
+*LF = \LF();
+*CRLF = \CRLF();
+
+sub sockaddr_in {
+ if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
+ my($af, $port, @quad) = @_;
+ warnings::warn "6-ARG sockaddr_in call is deprecated"
+ if warnings::enabled();
+ pack_sockaddr_in($port, inet_aton(join('.', @quad)));
+ } elsif (wantarray) {
+ croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
+ unpack_sockaddr_in(@_);
+ } else {
+ croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2;
+ pack_sockaddr_in(@_);
+ }
+}
+
+sub sockaddr_un {
+ if (wantarray) {
+ croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1;
+ unpack_sockaddr_un(@_);
+ } else {
+ croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1;
+ pack_sockaddr_un(@_);
+ }
+}
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ croak "&Socket::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ if ($error) {
+ croak $error;
+ }
+ *$AUTOLOAD = sub { $val };
+ goto &$AUTOLOAD;
+}
+
+XSLoader::load 'Socket', $VERSION;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Storable.pm b/Master/tlpkg/tlperl/lib/Storable.pm
new file mode 100644
index 00000000000..7627943b55d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Storable.pm
@@ -0,0 +1,1188 @@
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+
+require DynaLoader;
+require Exporter;
+package Storable; @ISA = qw(Exporter DynaLoader);
+
+@EXPORT = qw(store retrieve);
+@EXPORT_OK = qw(
+ nstore store_fd nstore_fd fd_retrieve
+ freeze nfreeze thaw
+ dclone
+ retrieve_fd
+ lock_store lock_nstore lock_retrieve
+ file_magic read_magic
+);
+
+use AutoLoader;
+use FileHandle;
+use vars qw($canonical $forgive_me $VERSION);
+
+$VERSION = '2.22';
+*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
+
+#
+# Use of Log::Agent is optional
+#
+
+{
+ local $SIG{__DIE__};
+ eval "use Log::Agent";
+}
+
+require Carp;
+
+#
+# They might miss :flock in Fcntl
+#
+
+BEGIN {
+ if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) {
+ Fcntl->import(':flock');
+ } else {
+ eval q{
+ sub LOCK_SH () {1}
+ sub LOCK_EX () {2}
+ };
+ }
+}
+
+sub CLONE {
+ # clone context under threads
+ Storable::init_perinterp();
+}
+
+# Can't Autoload cleanly as this clashes 8.3 with &retrieve
+sub retrieve_fd { &fd_retrieve } # Backward compatibility
+
+# By default restricted hashes are downgraded on earlier perls.
+
+$Storable::downgrade_restricted = 1;
+$Storable::accept_future_minor = 1;
+bootstrap Storable;
+1;
+__END__
+#
+# Use of Log::Agent is optional. If it hasn't imported these subs then
+# Autoloader will kindly supply our fallback implementation.
+#
+
+sub logcroak {
+ Carp::croak(@_);
+}
+
+sub logcarp {
+ Carp::carp(@_);
+}
+
+#
+# Determine whether locking is possible, but only when needed.
+#
+
+sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK {
+ return $CAN_FLOCK if defined $CAN_FLOCK;
+ require Config; import Config;
+ return $CAN_FLOCK =
+ $Config{'d_flock'} ||
+ $Config{'d_fcntl_can_lock'} ||
+ $Config{'d_lockf'};
+}
+
+sub show_file_magic {
+ print <<EOM;
+#
+# To recognize the data files of the Perl module Storable,
+# the following lines need to be added to the local magic(5) file,
+# usually either /usr/share/misc/magic or /etc/magic.
+#
+0 string perl-store perl Storable(v0.6) data
+>4 byte >0 (net-order %d)
+>>4 byte &01 (network-ordered)
+>>4 byte =3 (major 1)
+>>4 byte =2 (major 1)
+
+0 string pst0 perl Storable(v0.7) data
+>4 byte >0
+>>4 byte &01 (network-ordered)
+>>4 byte =5 (major 2)
+>>4 byte =4 (major 2)
+>>5 byte >0 (minor %d)
+EOM
+}
+
+sub file_magic {
+ my $file = shift;
+ my $fh = new FileHandle;
+ open($fh, "<". $file) || die "Can't open '$file': $!";
+ binmode($fh);
+ defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
+ close($fh);
+
+ $file = "./$file" unless $file; # ensure TRUE value
+
+ return read_magic($buf, $file);
+}
+
+sub read_magic {
+ my($buf, $file) = @_;
+ my %info;
+
+ my $buflen = length($buf);
+ my $magic;
+ if ($buf =~ s/^(pst0|perl-store)//) {
+ $magic = $1;
+ $info{file} = $file || 1;
+ }
+ else {
+ return undef if $file;
+ $magic = "";
+ }
+
+ return undef unless length($buf);
+
+ my $net_order;
+ if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) {
+ $info{version} = -1;
+ $net_order = 0;
+ }
+ else {
+ $net_order = ord(substr($buf, 0, 1, ""));
+ my $major = $net_order >> 1;
+ return undef if $major > 4; # sanity (assuming we never go that high)
+ $info{major} = $major;
+ $net_order &= 0x01;
+ if ($major > 1) {
+ return undef unless length($buf);
+ my $minor = ord(substr($buf, 0, 1, ""));
+ $info{minor} = $minor;
+ $info{version} = "$major.$minor";
+ $info{version_nv} = sprintf "%d.%03d", $major, $minor;
+ }
+ else {
+ $info{version} = $major;
+ }
+ }
+ $info{version_nv} ||= $info{version};
+ $info{netorder} = $net_order;
+
+ unless ($net_order) {
+ return undef unless length($buf);
+ my $len = ord(substr($buf, 0, 1, ""));
+ return undef unless length($buf) >= $len;
+ return undef unless $len == 4 || $len == 8; # sanity
+ $info{byteorder} = substr($buf, 0, $len, "");
+ $info{intsize} = ord(substr($buf, 0, 1, ""));
+ $info{longsize} = ord(substr($buf, 0, 1, ""));
+ $info{ptrsize} = ord(substr($buf, 0, 1, ""));
+ if ($info{version_nv} >= 2.002) {
+ return undef unless length($buf);
+ $info{nvsize} = ord(substr($buf, 0, 1, ""));
+ }
+ }
+ $info{hdrsize} = $buflen - length($buf);
+
+ return \%info;
+}
+
+sub BIN_VERSION_NV {
+ sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
+}
+
+sub BIN_WRITE_VERSION_NV {
+ sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR();
+}
+
+#
+# store
+#
+# Store target object hierarchy, identified by a reference to its root.
+# The stored object tree may later be retrieved to memory via retrieve.
+# Returns undef if an I/O error occurred, in which case the file is
+# removed.
+#
+sub store {
+ return _store(\&pstore, @_, 0);
+}
+
+#
+# nstore
+#
+# Same as store, but in network order.
+#
+sub nstore {
+ return _store(\&net_pstore, @_, 0);
+}
+
+#
+# lock_store
+#
+# Same as store, but flock the file first (advisory locking).
+#
+sub lock_store {
+ return _store(\&pstore, @_, 1);
+}
+
+#
+# lock_nstore
+#
+# Same as nstore, but flock the file first (advisory locking).
+#
+sub lock_nstore {
+ return _store(\&net_pstore, @_, 1);
+}
+
+# Internal store to file routine
+sub _store {
+ my $xsptr = shift;
+ my $self = shift;
+ my ($file, $use_locking) = @_;
+ logcroak "not a reference" unless ref($self);
+ logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist
+ local *FILE;
+ if ($use_locking) {
+ open(FILE, ">>$file") || logcroak "can't write into $file: $!";
+ unless (&CAN_FLOCK) {
+ logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O";
+ return undef;
+ }
+ flock(FILE, LOCK_EX) ||
+ logcroak "can't get exclusive lock on $file: $!";
+ truncate FILE, 0;
+ # Unlocking will happen when FILE is closed
+ } else {
+ open(FILE, ">$file") || logcroak "can't create $file: $!";
+ }
+ binmode FILE; # Archaic systems...
+ my $da = $@; # Don't mess if called from exception handler
+ my $ret;
+ # Call C routine nstore or pstore, depending on network order
+ eval { $ret = &$xsptr(*FILE, $self) };
+ close(FILE) or $ret = undef;
+ unlink($file) or warn "Can't unlink $file: $!\n" if $@ || !defined $ret;
+ logcroak $@ if $@ =~ s/\.?\n$/,/;
+ $@ = $da;
+ return $ret ? $ret : undef;
+}
+
+#
+# store_fd
+#
+# Same as store, but perform on an already opened file descriptor instead.
+# Returns undef if an I/O error occurred.
+#
+sub store_fd {
+ return _store_fd(\&pstore, @_);
+}
+
+#
+# nstore_fd
+#
+# Same as store_fd, but in network order.
+#
+sub nstore_fd {
+ my ($self, $file) = @_;
+ return _store_fd(\&net_pstore, @_);
+}
+
+# Internal store routine on opened file descriptor
+sub _store_fd {
+ my $xsptr = shift;
+ my $self = shift;
+ my ($file) = @_;
+ logcroak "not a reference" unless ref($self);
+ logcroak "too many arguments" unless @_ == 1; # No @foo in arglist
+ my $fd = fileno($file);
+ logcroak "not a valid file descriptor" unless defined $fd;
+ my $da = $@; # Don't mess if called from exception handler
+ my $ret;
+ # Call C routine nstore or pstore, depending on network order
+ eval { $ret = &$xsptr($file, $self) };
+ logcroak $@ if $@ =~ s/\.?\n$/,/;
+ local $\; print $file ''; # Autoflush the file if wanted
+ $@ = $da;
+ return $ret ? $ret : undef;
+}
+
+#
+# freeze
+#
+# Store oject and its hierarchy in memory and return a scalar
+# containing the result.
+#
+sub freeze {
+ _freeze(\&mstore, @_);
+}
+
+#
+# nfreeze
+#
+# Same as freeze but in network order.
+#
+sub nfreeze {
+ _freeze(\&net_mstore, @_);
+}
+
+# Internal freeze routine
+sub _freeze {
+ my $xsptr = shift;
+ my $self = shift;
+ logcroak "not a reference" unless ref($self);
+ logcroak "too many arguments" unless @_ == 0; # No @foo in arglist
+ my $da = $@; # Don't mess if called from exception handler
+ my $ret;
+ # Call C routine mstore or net_mstore, depending on network order
+ eval { $ret = &$xsptr($self) };
+ logcroak $@ if $@ =~ s/\.?\n$/,/;
+ $@ = $da;
+ return $ret ? $ret : undef;
+}
+
+#
+# retrieve
+#
+# Retrieve object hierarchy from disk, returning a reference to the root
+# object of that tree.
+#
+sub retrieve {
+ _retrieve($_[0], 0);
+}
+
+#
+# lock_retrieve
+#
+# Same as retrieve, but with advisory locking.
+#
+sub lock_retrieve {
+ _retrieve($_[0], 1);
+}
+
+# Internal retrieve routine
+sub _retrieve {
+ my ($file, $use_locking) = @_;
+ local *FILE;
+ open(FILE, $file) || logcroak "can't open $file: $!";
+ binmode FILE; # Archaic systems...
+ my $self;
+ my $da = $@; # Could be from exception handler
+ if ($use_locking) {
+ unless (&CAN_FLOCK) {
+ logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O";
+ return undef;
+ }
+ flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!";
+ # Unlocking will happen when FILE is closed
+ }
+ eval { $self = pretrieve(*FILE) }; # Call C routine
+ close(FILE);
+ logcroak $@ if $@ =~ s/\.?\n$/,/;
+ $@ = $da;
+ return $self;
+}
+
+#
+# fd_retrieve
+#
+# Same as retrieve, but perform from an already opened file descriptor instead.
+#
+sub fd_retrieve {
+ my ($file) = @_;
+ my $fd = fileno($file);
+ logcroak "not a valid file descriptor" unless defined $fd;
+ my $self;
+ my $da = $@; # Could be from exception handler
+ eval { $self = pretrieve($file) }; # Call C routine
+ logcroak $@ if $@ =~ s/\.?\n$/,/;
+ $@ = $da;
+ return $self;
+}
+
+#
+# thaw
+#
+# Recreate objects in memory from an existing frozen image created
+# by freeze. If the frozen image passed is undef, return undef.
+#
+sub thaw {
+ my ($frozen) = @_;
+ return undef unless defined $frozen;
+ my $self;
+ my $da = $@; # Could be from exception handler
+ eval { $self = mretrieve($frozen) }; # Call C routine
+ logcroak $@ if $@ =~ s/\.?\n$/,/;
+ $@ = $da;
+ return $self;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Storable - persistence for Perl data structures
+
+=head1 SYNOPSIS
+
+ use Storable;
+ store \%table, 'file';
+ $hashref = retrieve('file');
+
+ use Storable qw(nstore store_fd nstore_fd freeze thaw dclone);
+
+ # Network order
+ nstore \%table, 'file';
+ $hashref = retrieve('file'); # There is NO nretrieve()
+
+ # Storing to and retrieving from an already opened file
+ store_fd \@array, \*STDOUT;
+ nstore_fd \%table, \*STDOUT;
+ $aryref = fd_retrieve(\*SOCKET);
+ $hashref = fd_retrieve(\*SOCKET);
+
+ # Serializing to memory
+ $serialized = freeze \%table;
+ %table_clone = %{ thaw($serialized) };
+
+ # Deep (recursive) cloning
+ $cloneref = dclone($ref);
+
+ # Advisory locking
+ use Storable qw(lock_store lock_nstore lock_retrieve)
+ lock_store \%table, 'file';
+ lock_nstore \%table, 'file';
+ $hashref = lock_retrieve('file');
+
+=head1 DESCRIPTION
+
+The Storable package brings persistence to your Perl data structures
+containing SCALAR, ARRAY, HASH or REF objects, i.e. anything that can be
+conveniently stored to disk and retrieved at a later time.
+
+It can be used in the regular procedural way by calling C<store> with
+a reference to the object to be stored, along with the file name where
+the image should be written.
+
+The routine returns C<undef> for I/O problems or other internal error,
+a true value otherwise. Serious errors are propagated as a C<die> exception.
+
+To retrieve data stored to disk, use C<retrieve> with a file name.
+The objects stored into that file are recreated into memory for you,
+and a I<reference> to the root object is returned. In case an I/O error
+occurs while reading, C<undef> is returned instead. Other serious
+errors are propagated via C<die>.
+
+Since storage is performed recursively, you might want to stuff references
+to objects that share a lot of common data into a single array or hash
+table, and then store that object. That way, when you retrieve back the
+whole thing, the objects will continue to share what they originally shared.
+
+At the cost of a slight header overhead, you may store to an already
+opened file descriptor using the C<store_fd> routine, and retrieve
+from a file via C<fd_retrieve>. Those names aren't imported by default,
+so you will have to do that explicitly if you need those routines.
+The file descriptor you supply must be already opened, for read
+if you're going to retrieve and for write if you wish to store.
+
+ store_fd(\%table, *STDOUT) || die "can't store to stdout\n";
+ $hashref = fd_retrieve(*STDIN);
+
+You can also store data in network order to allow easy sharing across
+multiple platforms, or when storing on a socket known to be remotely
+connected. The routines to call have an initial C<n> prefix for I<network>,
+as in C<nstore> and C<nstore_fd>. At retrieval time, your data will be
+correctly restored so you don't have to know whether you're restoring
+from native or network ordered data. Double values are stored stringified
+to ensure portability as well, at the slight risk of loosing some precision
+in the last decimals.
+
+When using C<fd_retrieve>, objects are retrieved in sequence, one
+object (i.e. one recursive tree) per associated C<store_fd>.
+
+If you're more from the object-oriented camp, you can inherit from
+Storable and directly store your objects by invoking C<store> as
+a method. The fact that the root of the to-be-stored tree is a
+blessed reference (i.e. an object) is special-cased so that the
+retrieve does not provide a reference to that object but rather the
+blessed object reference itself. (Otherwise, you'd get a reference
+to that blessed object).
+
+=head1 MEMORY STORE
+
+The Storable engine can also store data into a Perl scalar instead, to
+later retrieve them. This is mainly used to freeze a complex structure in
+some safe compact memory place (where it can possibly be sent to another
+process via some IPC, since freezing the structure also serializes it in
+effect). Later on, and maybe somewhere else, you can thaw the Perl scalar
+out and recreate the original complex structure in memory.
+
+Surprisingly, the routines to be called are named C<freeze> and C<thaw>.
+If you wish to send out the frozen scalar to another machine, use
+C<nfreeze> instead to get a portable image.
+
+Note that freezing an object structure and immediately thawing it
+actually achieves a deep cloning of that structure:
+
+ dclone(.) = thaw(freeze(.))
+
+Storable provides you with a C<dclone> interface which does not create
+that intermediary scalar but instead freezes the structure in some
+internal memory space and then immediately thaws it out.
+
+=head1 ADVISORY LOCKING
+
+The C<lock_store> and C<lock_nstore> routine are equivalent to
+C<store> and C<nstore>, except that they get an exclusive lock on
+the file before writing. Likewise, C<lock_retrieve> does the same
+as C<retrieve>, but also gets a shared lock on the file before reading.
+
+As with any advisory locking scheme, the protection only works if you
+systematically use C<lock_store> and C<lock_retrieve>. If one side of
+your application uses C<store> whilst the other uses C<lock_retrieve>,
+you will get no protection at all.
+
+The internal advisory locking is implemented using Perl's flock()
+routine. If your system does not support any form of flock(), or if
+you share your files across NFS, you might wish to use other forms
+of locking by using modules such as LockFile::Simple which lock a
+file using a filesystem entry, instead of locking the file descriptor.
+
+=head1 SPEED
+
+The heart of Storable is written in C for decent speed. Extra low-level
+optimizations have been made when manipulating perl internals, to
+sacrifice encapsulation for the benefit of greater speed.
+
+=head1 CANONICAL REPRESENTATION
+
+Normally, Storable stores elements of hashes in the order they are
+stored internally by Perl, i.e. pseudo-randomly. If you set
+C<$Storable::canonical> to some C<TRUE> value, Storable will store
+hashes with the elements sorted by their key. This allows you to
+compare data structures by comparing their frozen representations (or
+even the compressed frozen representations), which can be useful for
+creating lookup tables for complicated queries.
+
+Canonical order does not imply network order; those are two orthogonal
+settings.
+
+=head1 CODE REFERENCES
+
+Since Storable version 2.05, CODE references may be serialized with
+the help of L<B::Deparse>. To enable this feature, set
+C<$Storable::Deparse> to a true value. To enable deserialization,
+C<$Storable::Eval> should be set to a true value. Be aware that
+deserialization is done through C<eval>, which is dangerous if the
+Storable file contains malicious data. You can set C<$Storable::Eval>
+to a subroutine reference which would be used instead of C<eval>. See
+below for an example using a L<Safe> compartment for deserialization
+of CODE references.
+
+If C<$Storable::Deparse> and/or C<$Storable::Eval> are set to false
+values, then the value of C<$Storable::forgive_me> (see below) is
+respected while serializing and deserializing.
+
+=head1 FORWARD COMPATIBILITY
+
+This release of Storable can be used on a newer version of Perl to
+serialize data which is not supported by earlier Perls. By default,
+Storable will attempt to do the right thing, by C<croak()>ing if it
+encounters data that it cannot deserialize. However, the defaults
+can be changed as follows:
+
+=over 4
+
+=item utf8 data
+
+Perl 5.6 added support for Unicode characters with code points > 255,
+and Perl 5.8 has full support for Unicode characters in hash keys.
+Perl internally encodes strings with these characters using utf8, and
+Storable serializes them as utf8. By default, if an older version of
+Perl encounters a utf8 value it cannot represent, it will C<croak()>.
+To change this behaviour so that Storable deserializes utf8 encoded
+values as the string of bytes (effectively dropping the I<is_utf8> flag)
+set C<$Storable::drop_utf8> to some C<TRUE> value. This is a form of
+data loss, because with C<$drop_utf8> true, it becomes impossible to tell
+whether the original data was the Unicode string, or a series of bytes
+that happen to be valid utf8.
+
+=item restricted hashes
+
+Perl 5.8 adds support for restricted hashes, which have keys
+restricted to a given set, and can have values locked to be read only.
+By default, when Storable encounters a restricted hash on a perl
+that doesn't support them, it will deserialize it as a normal hash,
+silently discarding any placeholder keys and leaving the keys and
+all values unlocked. To make Storable C<croak()> instead, set
+C<$Storable::downgrade_restricted> to a C<FALSE> value. To restore
+the default set it back to some C<TRUE> value.
+
+=item files from future versions of Storable
+
+Earlier versions of Storable would immediately croak if they encountered
+a file with a higher internal version number than the reading Storable
+knew about. Internal version numbers are increased each time new data
+types (such as restricted hashes) are added to the vocabulary of the file
+format. This meant that a newer Storable module had no way of writing a
+file readable by an older Storable, even if the writer didn't store newer
+data types.
+
+This version of Storable will defer croaking until it encounters a data
+type in the file that it does not recognize. This means that it will
+continue to read files generated by newer Storable modules which are careful
+in what they write out, making it easier to upgrade Storable modules in a
+mixed environment.
+
+The old behaviour of immediate croaking can be re-instated by setting
+C<$Storable::accept_future_minor> to some C<FALSE> value.
+
+=back
+
+All these variables have no effect on a newer Perl which supports the
+relevant feature.
+
+=head1 ERROR REPORTING
+
+Storable uses the "exception" paradigm, in that it does not try to workaround
+failures: if something bad happens, an exception is generated from the
+caller's perspective (see L<Carp> and C<croak()>). Use eval {} to trap
+those exceptions.
+
+When Storable croaks, it tries to report the error via the C<logcroak()>
+routine from the C<Log::Agent> package, if it is available.
+
+Normal errors are reported by having store() or retrieve() return C<undef>.
+Such errors are usually I/O errors (or truncated stream errors at retrieval).
+
+=head1 WIZARDS ONLY
+
+=head2 Hooks
+
+Any class may define hooks that will be called during the serialization
+and deserialization process on objects that are instances of that class.
+Those hooks can redefine the way serialization is performed (and therefore,
+how the symmetrical deserialization should be conducted).
+
+Since we said earlier:
+
+ dclone(.) = thaw(freeze(.))
+
+everything we say about hooks should also hold for deep cloning. However,
+hooks get to know whether the operation is a mere serialization, or a cloning.
+
+Therefore, when serializing hooks are involved,
+
+ dclone(.) <> thaw(freeze(.))
+
+Well, you could keep them in sync, but there's no guarantee it will always
+hold on classes somebody else wrote. Besides, there is little to gain in
+doing so: a serializing hook could keep only one attribute of an object,
+which is probably not what should happen during a deep cloning of that
+same object.
+
+Here is the hooking interface:
+
+=over 4
+
+=item C<STORABLE_freeze> I<obj>, I<cloning>
+
+The serializing hook, called on the object during serialization. It can be
+inherited, or defined in the class itself, like any other method.
+
+Arguments: I<obj> is the object to serialize, I<cloning> is a flag indicating
+whether we're in a dclone() or a regular serialization via store() or freeze().
+
+Returned value: A LIST C<($serialized, $ref1, $ref2, ...)> where $serialized
+is the serialized form to be used, and the optional $ref1, $ref2, etc... are
+extra references that you wish to let the Storable engine serialize.
+
+At deserialization time, you will be given back the same LIST, but all the
+extra references will be pointing into the deserialized structure.
+
+The B<first time> the hook is hit in a serialization flow, you may have it
+return an empty list. That will signal the Storable engine to further
+discard that hook for this class and to therefore revert to the default
+serialization of the underlying Perl data. The hook will again be normally
+processed in the next serialization.
+
+Unless you know better, serializing hook should always say:
+
+ sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return if $cloning; # Regular default serialization
+ ....
+ }
+
+in order to keep reasonable dclone() semantics.
+
+=item C<STORABLE_thaw> I<obj>, I<cloning>, I<serialized>, ...
+
+The deserializing hook called on the object during deserialization.
+But wait: if we're deserializing, there's no object yet... right?
+
+Wrong: the Storable engine creates an empty one for you. If you know Eiffel,
+you can view C<STORABLE_thaw> as an alternate creation routine.
+
+This means the hook can be inherited like any other method, and that
+I<obj> is your blessed reference for this particular instance.
+
+The other arguments should look familiar if you know C<STORABLE_freeze>:
+I<cloning> is true when we're part of a deep clone operation, I<serialized>
+is the serialized string you returned to the engine in C<STORABLE_freeze>,
+and there may be an optional list of references, in the same order you gave
+them at serialization time, pointing to the deserialized objects (which
+have been processed courtesy of the Storable engine).
+
+When the Storable engine does not find any C<STORABLE_thaw> hook routine,
+it tries to load the class by requiring the package dynamically (using
+the blessed package name), and then re-attempts the lookup. If at that
+time the hook cannot be located, the engine croaks. Note that this mechanism
+will fail if you define several classes in the same file, but L<perlmod>
+warned you.
+
+It is up to you to use this information to populate I<obj> the way you want.
+
+Returned value: none.
+
+=item C<STORABLE_attach> I<class>, I<cloning>, I<serialized>
+
+While C<STORABLE_freeze> and C<STORABLE_thaw> are useful for classes where
+each instance is independent, this mechanism has difficulty (or is
+incompatible) with objects that exist as common process-level or
+system-level resources, such as singleton objects, database pools, caches
+or memoized objects.
+
+The alternative C<STORABLE_attach> method provides a solution for these
+shared objects. Instead of C<STORABLE_freeze> --E<gt> C<STORABLE_thaw>,
+you implement C<STORABLE_freeze> --E<gt> C<STORABLE_attach> instead.
+
+Arguments: I<class> is the class we are attaching to, I<cloning> is a flag
+indicating whether we're in a dclone() or a regular de-serialization via
+thaw(), and I<serialized> is the stored string for the resource object.
+
+Because these resource objects are considered to be owned by the entire
+process/system, and not the "property" of whatever is being serialized,
+no references underneath the object should be included in the serialized
+string. Thus, in any class that implements C<STORABLE_attach>, the
+C<STORABLE_freeze> method cannot return any references, and C<Storable>
+will throw an error if C<STORABLE_freeze> tries to return references.
+
+All information required to "attach" back to the shared resource object
+B<must> be contained B<only> in the C<STORABLE_freeze> return string.
+Otherwise, C<STORABLE_freeze> behaves as normal for C<STORABLE_attach>
+classes.
+
+Because C<STORABLE_attach> is passed the class (rather than an object),
+it also returns the object directly, rather than modifying the passed
+object.
+
+Returned value: object of type C<class>
+
+=back
+
+=head2 Predicates
+
+Predicates are not exportable. They must be called by explicitly prefixing
+them with the Storable package name.
+
+=over 4
+
+=item C<Storable::last_op_in_netorder>
+
+The C<Storable::last_op_in_netorder()> predicate will tell you whether
+network order was used in the last store or retrieve operation. If you
+don't know how to use this, just forget about it.
+
+=item C<Storable::is_storing>
+
+Returns true if within a store operation (via STORABLE_freeze hook).
+
+=item C<Storable::is_retrieving>
+
+Returns true if within a retrieve operation (via STORABLE_thaw hook).
+
+=back
+
+=head2 Recursion
+
+With hooks comes the ability to recurse back to the Storable engine.
+Indeed, hooks are regular Perl code, and Storable is convenient when
+it comes to serializing and deserializing things, so why not use it
+to handle the serialization string?
+
+There are a few things you need to know, however:
+
+=over 4
+
+=item *
+
+You can create endless loops if the things you serialize via freeze()
+(for instance) point back to the object we're trying to serialize in
+the hook.
+
+=item *
+
+Shared references among objects will not stay shared: if we're serializing
+the list of object [A, C] where both object A and C refer to the SAME object
+B, and if there is a serializing hook in A that says freeze(B), then when
+deserializing, we'll get [A', C'] where A' refers to B', but C' refers to D,
+a deep clone of B'. The topology was not preserved.
+
+=back
+
+That's why C<STORABLE_freeze> lets you provide a list of references
+to serialize. The engine guarantees that those will be serialized in the
+same context as the other objects, and therefore that shared objects will
+stay shared.
+
+In the above [A, C] example, the C<STORABLE_freeze> hook could return:
+
+ ("something", $self->{B})
+
+and the B part would be serialized by the engine. In C<STORABLE_thaw>, you
+would get back the reference to the B' object, deserialized for you.
+
+Therefore, recursion should normally be avoided, but is nonetheless supported.
+
+=head2 Deep Cloning
+
+There is a Clone module available on CPAN which implements deep cloning
+natively, i.e. without freezing to memory and thawing the result. It is
+aimed to replace Storable's dclone() some day. However, it does not currently
+support Storable hooks to redefine the way deep cloning is performed.
+
+=head1 Storable magic
+
+Yes, there's a lot of that :-) But more precisely, in UNIX systems
+there's a utility called C<file>, which recognizes data files based on
+their contents (usually their first few bytes). For this to work,
+a certain file called F<magic> needs to taught about the I<signature>
+of the data. Where that configuration file lives depends on the UNIX
+flavour; often it's something like F</usr/share/misc/magic> or
+F</etc/magic>. Your system administrator needs to do the updating of
+the F<magic> file. The necessary signature information is output to
+STDOUT by invoking Storable::show_file_magic(). Note that the GNU
+implementation of the C<file> utility, version 3.38 or later,
+is expected to contain support for recognising Storable files
+out-of-the-box, in addition to other kinds of Perl files.
+
+You can also use the following functions to extract the file header
+information from Storable images:
+
+=over
+
+=item $info = Storable::file_magic( $filename )
+
+If the given file is a Storable image return a hash describing it. If
+the file is readable, but not a Storable image return C<undef>. If
+the file does not exist or is unreadable then croak.
+
+The hash returned has the following elements:
+
+=over
+
+=item C<version>
+
+This returns the file format version. It is a string like "2.7".
+
+Note that this version number is not the same as the version number of
+the Storable module itself. For instance Storable v0.7 create files
+in format v2.0 and Storable v2.15 create files in format v2.7. The
+file format version number only increment when additional features
+that would confuse older versions of the module are added.
+
+Files older than v2.0 will have the one of the version numbers "-1",
+"0" or "1". No minor number was used at that time.
+
+=item C<version_nv>
+
+This returns the file format version as number. It is a string like
+"2.007". This value is suitable for numeric comparisons.
+
+The constant function C<Storable::BIN_VERSION_NV> returns a comparable
+number that represent the highest file version number that this
+version of Storable fully support (but see discussion of
+C<$Storable::accept_future_minor> above). The constant
+C<Storable::BIN_WRITE_VERSION_NV> function returns what file version
+is written and might be less than C<Storable::BIN_VERSION_NV> in some
+configuations.
+
+=item C<major>, C<minor>
+
+This also returns the file format version. If the version is "2.7"
+then major would be 2 and minor would be 7. The minor element is
+missing for when major is less than 2.
+
+=item C<hdrsize>
+
+The is the number of bytes that the Storable header occupies.
+
+=item C<netorder>
+
+This is TRUE if the image store data in network order. This means
+that it was created with nstore() or similar.
+
+=item C<byteorder>
+
+This is only present when C<netorder> is FALSE. It is the
+$Config{byteorder} string of the perl that created this image. It is
+a string like "1234" (32 bit little endian) or "87654321" (64 bit big
+endian). This must match the current perl for the image to be
+readable by Storable.
+
+=item C<intsize>, C<longsize>, C<ptrsize>, C<nvsize>
+
+These are only present when C<netorder> is FALSE. These are the sizes of
+various C datatypes of the perl that created this image. These must
+match the current perl for the image to be readable by Storable.
+
+The C<nvsize> element is only present for file format v2.2 and
+higher.
+
+=item C<file>
+
+The name of the file.
+
+=back
+
+=item $info = Storable::read_magic( $buffer )
+
+=item $info = Storable::read_magic( $buffer, $must_be_file )
+
+The $buffer should be a Storable image or the first few bytes of it.
+If $buffer starts with a Storable header, then a hash describing the
+image is returned, otherwise C<undef> is returned.
+
+The hash has the same structure as the one returned by
+Storable::file_magic(). The C<file> element is true if the image is a
+file image.
+
+If the $must_be_file argument is provided and is TRUE, then return
+C<undef> unless the image looks like it belongs to a file dump.
+
+The maximum size of a Storable header is currently 21 bytes. If the
+provided $buffer is only the first part of a Storable image it should
+at least be this long to ensure that read_magic() will recognize it as
+such.
+
+=back
+
+=head1 EXAMPLES
+
+Here are some code samples showing a possible usage of Storable:
+
+ use Storable qw(store retrieve freeze thaw dclone);
+
+ %color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1);
+
+ store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n";
+
+ $colref = retrieve('mycolors');
+ die "Unable to retrieve from mycolors!\n" unless defined $colref;
+ printf "Blue is still %lf\n", $colref->{'Blue'};
+
+ $colref2 = dclone(\%color);
+
+ $str = freeze(\%color);
+ printf "Serialization of %%color is %d bytes long.\n", length($str);
+ $colref3 = thaw($str);
+
+which prints (on my machine):
+
+ Blue is still 0.100000
+ Serialization of %color is 102 bytes long.
+
+Serialization of CODE references and deserialization in a safe
+compartment:
+
+=for example begin
+
+ use Storable qw(freeze thaw);
+ use Safe;
+ use strict;
+ my $safe = new Safe;
+ # because of opcodes used in "use strict":
+ $safe->permit(qw(:default require));
+ local $Storable::Deparse = 1;
+ local $Storable::Eval = sub { $safe->reval($_[0]) };
+ my $serialized = freeze(sub { 42 });
+ my $code = thaw($serialized);
+ $code->() == 42;
+
+=for example end
+
+=for example_testing
+ is( $code->(), 42 );
+
+=head1 WARNING
+
+If you're using references as keys within your hash tables, you're bound
+to be disappointed when retrieving your data. Indeed, Perl stringifies
+references used as hash table keys. If you later wish to access the
+items via another reference stringification (i.e. using the same
+reference that was used for the key originally to record the value into
+the hash table), it will work because both references stringify to the
+same string.
+
+It won't work across a sequence of C<store> and C<retrieve> operations,
+however, because the addresses in the retrieved objects, which are
+part of the stringified references, will probably differ from the
+original addresses. The topology of your structure is preserved,
+but not hidden semantics like those.
+
+On platforms where it matters, be sure to call C<binmode()> on the
+descriptors that you pass to Storable functions.
+
+Storing data canonically that contains large hashes can be
+significantly slower than storing the same data normally, as
+temporary arrays to hold the keys for each hash have to be allocated,
+populated, sorted and freed. Some tests have shown a halving of the
+speed of storing -- the exact penalty will depend on the complexity of
+your data. There is no slowdown on retrieval.
+
+=head1 BUGS
+
+You can't store GLOB, FORMLINE, REGEXP, etc.... If you can define semantics
+for those operations, feel free to enhance Storable so that it can
+deal with them.
+
+The store functions will C<croak> if they run into such references
+unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that
+case, the fatal message is turned in a warning and some
+meaningless string is stored instead.
+
+Setting C<$Storable::canonical> may not yield frozen strings that
+compare equal due to possible stringification of numbers. When the
+string version of a scalar exists, it is the form stored; therefore,
+if you happen to use your numbers as strings between two freezing
+operations on the same data structures, you will get different
+results.
+
+When storing doubles in network order, their value is stored as text.
+However, you should also not expect non-numeric floating-point values
+such as infinity and "not a number" to pass successfully through a
+nstore()/retrieve() pair.
+
+As Storable neither knows nor cares about character sets (although it
+does know that characters may be more than eight bits wide), any difference
+in the interpretation of character codes between a host and a target
+system is your problem. In particular, if host and target use different
+code points to represent the characters used in the text representation
+of floating-point numbers, you will not be able be able to exchange
+floating-point data, even with nstore().
+
+C<Storable::drop_utf8> is a blunt tool. There is no facility either to
+return B<all> strings as utf8 sequences, or to attempt to convert utf8
+data back to 8 bit and C<croak()> if the conversion fails.
+
+Prior to Storable 2.01, no distinction was made between signed and
+unsigned integers on storing. By default Storable prefers to store a
+scalars string representation (if it has one) so this would only cause
+problems when storing large unsigned integers that had never been converted
+to string or floating point. In other words values that had been generated
+by integer operations such as logic ops and then not used in any string or
+arithmetic context before storing.
+
+=head2 64 bit data in perl 5.6.0 and 5.6.1
+
+This section only applies to you if you have existing data written out
+by Storable 2.02 or earlier on perl 5.6.0 or 5.6.1 on Unix or Linux which
+has been configured with 64 bit integer support (not the default)
+If you got a precompiled perl, rather than running Configure to build
+your own perl from source, then it almost certainly does not affect you,
+and you can stop reading now (unless you're curious). If you're using perl
+on Windows it does not affect you.
+
+Storable writes a file header which contains the sizes of various C
+language types for the C compiler that built Storable (when not writing in
+network order), and will refuse to load files written by a Storable not
+on the same (or compatible) architecture. This check and a check on
+machine byteorder is needed because the size of various fields in the file
+are given by the sizes of the C language types, and so files written on
+different architectures are incompatible. This is done for increased speed.
+(When writing in network order, all fields are written out as standard
+lengths, which allows full interworking, but takes longer to read and write)
+
+Perl 5.6.x introduced the ability to optional configure the perl interpreter
+to use C's C<long long> type to allow scalars to store 64 bit integers on 32
+bit systems. However, due to the way the Perl configuration system
+generated the C configuration files on non-Windows platforms, and the way
+Storable generates its header, nothing in the Storable file header reflected
+whether the perl writing was using 32 or 64 bit integers, despite the fact
+that Storable was storing some data differently in the file. Hence Storable
+running on perl with 64 bit integers will read the header from a file
+written by a 32 bit perl, not realise that the data is actually in a subtly
+incompatible format, and then go horribly wrong (possibly crashing) if it
+encountered a stored integer. This is a design failure.
+
+Storable has now been changed to write out and read in a file header with
+information about the size of integers. It's impossible to detect whether
+an old file being read in was written with 32 or 64 bit integers (they have
+the same header) so it's impossible to automatically switch to a correct
+backwards compatibility mode. Hence this Storable defaults to the new,
+correct behaviour.
+
+What this means is that if you have data written by Storable 1.x running
+on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux
+then by default this Storable will refuse to read it, giving the error
+I<Byte order is not compatible>. If you have such data then you you
+should set C<$Storable::interwork_56_64bit> to a true value to make this
+Storable read and write files with the old header. You should also
+migrate your data, or any older perl you are communicating with, to this
+current version of Storable.
+
+If you don't have data written with specific configuration of perl described
+above, then you do not and should not do anything. Don't set the flag -
+not only will Storable on an identically configured perl refuse to load them,
+but Storable a differently configured perl will load them believing them
+to be correct for it, and then may well fail or crash part way through
+reading them.
+
+=head1 CREDITS
+
+Thank you to (in chronological order):
+
+ Jarkko Hietaniemi <jhi@iki.fi>
+ Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ Benjamin A. Holzman <bah@ecnvantage.com>
+ Andrew Ford <A.Ford@ford-mason.co.uk>
+ Gisle Aas <gisle@aas.no>
+ Jeff Gresham <gresham_jeffrey@jpmorgan.com>
+ Murray Nesbitt <murray@activestate.com>
+ Marc Lehmann <pcg@opengroup.org>
+ Justin Banks <justinb@wamnet.com>
+ Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!)
+ Salvador Ortiz Garcia <sog@msg.com.mx>
+ Dominic Dunlop <domo@computer.org>
+ Erik Haugan <erik@solbors.no>
+
+for their bug reports, suggestions and contributions.
+
+Benjamin Holzman contributed the tied variable support, Andrew Ford
+contributed the canonical order for hashes, and Gisle Aas fixed
+a few misunderstandings of mine regarding the perl internals,
+and optimized the emission of "tags" in the output streams by
+simply counting the objects instead of tagging them (leading to
+a binary incompatibility for the Storable image starting at version
+0.6--older images are, of course, still properly understood).
+Murray Nesbitt made Storable thread-safe. Marc Lehmann added overloading
+and references to tied items support.
+
+=head1 AUTHOR
+
+Storable was written by Raphael Manfredi F<E<lt>Raphael_Manfredi@pobox.comE<gt>>
+Maintenance is now done by the perl5-porters F<E<lt>perl5-porters@perl.orgE<gt>>
+
+Please e-mail us with problems, bug fixes, comments and complaints,
+although if you have compliments you should send them to Raphael.
+Please don't e-mail Raphael with problems, as he no longer works on
+Storable, and your message will be delayed while he forwards it to us.
+
+=head1 SEE ALSO
+
+L<Clone>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Switch.pm b/Master/tlpkg/tlperl/lib/Switch.pm
new file mode 100644
index 00000000000..2189ae06c6b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Switch.pm
@@ -0,0 +1,875 @@
+package Switch;
+
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+use if $] >= 5.011, 'deprecate';
+
+$VERSION = '2.16';
+
+
+# LOAD FILTERING MODULE...
+use Filter::Util::Call;
+
+sub __();
+
+# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
+
+$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
+
+my $offset;
+my $fallthrough;
+my ($Perl5, $Perl6) = (0,0);
+
+sub import
+{
+ $fallthrough = grep /\bfallthrough\b/, @_;
+ $offset = (caller)[2]+1;
+ filter_add({}) unless @_>1 && $_[1] eq 'noimport';
+ my $pkg = caller;
+ no strict 'refs';
+ for ( qw( on_defined on_exists ) )
+ {
+ *{"${pkg}::$_"} = \&$_;
+ }
+ *{"${pkg}::__"} = \&__ if grep /__/, @_;
+ $Perl6 = 1 if grep(/Perl\s*6/i, @_);
+ $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
+ 1;
+}
+
+sub unimport
+{
+ filter_del()
+}
+
+sub filter
+{
+ my($self) = @_ ;
+ local $Switch::file = (caller)[1];
+
+ my $status = 1;
+ $status = filter_read(1_000_000);
+ return $status if $status<0;
+ $_ = filter_blocks($_,$offset);
+ $_ = "# line $offset\n" . $_ if $offset; undef $offset;
+ return $status;
+}
+
+use Text::Balanced ':ALL';
+
+sub line
+{
+ my ($pretext,$offset) = @_;
+ ($pretext=~tr/\n/\n/)+($offset||0);
+}
+
+sub is_block
+{
+ local $SIG{__WARN__}=sub{die$@};
+ local $^W=1;
+ my $ishash = defined eval 'my $hr='.$_[0];
+ undef $@;
+ return !$ishash;
+}
+
+my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
+ | ^__(DATA|END)__\n.*
+ /smx;
+
+my $casecounter = 1;
+sub filter_blocks
+{
+ my ($source, $line) = @_;
+ return $source unless $Perl5 && $source =~ /case|switch/
+ || $Perl6 && $source =~ /when|given|default/;
+ pos $source = 0;
+ my $text = "";
+ component: while (pos $source < length $source)
+ {
+ if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
+ {
+ $text .= q{use Switch 'noimport'};
+ next component;
+ }
+ my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
+ if (defined $pos[0])
+ {
+ my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
+ my $iEol;
+ if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
+ substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
+ index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
+ ($iEol = index( $source, "\n", $pos[4] )) > 0 &&
+ $iEol < $pos[8] ){ # embedded newlines
+ # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
+ pos( $source ) = $pos[6];
+ $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
+ } else {
+ $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
+ }
+ next component;
+ }
+ if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
+ $text .= $1;
+ next component;
+ }
+ @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
+ if (defined $pos[0])
+ {
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
+ next component;
+ }
+
+ if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
+ || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
+ || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
+ {
+ my $keyword = $3;
+ my $arg = $4;
+ $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
+ unless ($arg) {
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
+ or do {
+ die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ }
+ $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
+ $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
+ $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
+ $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
+ @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
+ or do {
+ die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
+ };
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
+ $text .= $code . 'continue {last}';
+ next component;
+ }
+ elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
+ || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
+ || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
+ {
+ my $keyword = $2;
+ $text .= $1 . ($keyword eq "default"
+ ? "if (1)"
+ : "if (Switch::case");
+
+ if ($keyword eq "default") {
+ # Nothing to do
+ }
+ elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
+ my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "sub " if is_block $code;
+ $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
+ }
+ elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
+ $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
+ $code =~ s {^\s*[(]\s*/} { ( qr/} ||
+ $code =~ s {^\s*[(]\s*qw} { ( \\qw};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s {^\s*%} { \%} ||
+ $code =~ s {^\s*@} { \@};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
+ my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
+ $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
+ $code =~ s {^\s*m} { qr} ||
+ $code =~ s {^\s*/} { qr/} ||
+ $code =~ s {^\s*qw} { \\qw};
+ $text .= " " if $pos[0] < $pos[2];
+ $text .= "$code)";
+ }
+ elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
+ || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
+ my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
+ $text .= ' \\' if $2 eq '%';
+ $text .= " $code)";
+ }
+ else {
+ die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
+ }
+
+ die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
+ unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
+
+ do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
+ or do {
+ if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
+ $casecounter++;
+ next component;
+ }
+ die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
+ };
+ my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
+ $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
+ unless $fallthrough;
+ $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
+ $casecounter++;
+ next component;
+ }
+
+ $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
+ $text .= $1;
+ }
+ $text;
+}
+
+
+
+sub in
+{
+ my ($x,$y) = @_;
+ my @numy;
+ for my $nextx ( @$x )
+ {
+ my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
+ for my $j ( 0..$#$y )
+ {
+ my $nexty = $y->[$j];
+ push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
+ if @numy <= $j;
+ return 1 if $numx && $numy[$j] && $nextx==$nexty
+ || $nextx eq $nexty;
+
+ }
+ }
+ return "";
+}
+
+sub on_exists
+{
+ my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+ [ keys %$ref ]
+}
+
+sub on_defined
+{
+ my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
+ [ grep { defined $ref->{$_} } keys %$ref ]
+}
+
+sub switch(;$)
+{
+ my ($s_val) = @_ ? $_[0] : $_;
+ my $s_ref = ref $s_val;
+
+ if ($s_ref eq 'CODE')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ return $s_val == $c_val if ref $c_val eq 'CODE';
+ return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
+ return $s_val->($c_val);
+ };
+ }
+ elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val == $c_val if $c_ref eq ""
+ && defined $c_val
+ && (~$c_val&$c_val) eq 0;
+ return $s_val eq $c_val if $c_ref eq "";
+ return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return scalar $s_val=~/$c_val/
+ if $c_ref eq 'Regexp';
+ return scalar $c_val->{$s_val}
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq "") # STRING SCALAR
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val eq $c_val if $c_ref eq "";
+ return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return scalar $s_val=~/$c_val/
+ if $c_ref eq 'Regexp';
+ return scalar $c_val->{$s_val}
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'ARRAY')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return in($s_val,[$c_val]) if $c_ref eq "";
+ return in($s_val,$c_val) if $c_ref eq 'ARRAY';
+ return $c_val->(@$s_val) if $c_ref eq 'CODE';
+ return $c_val->call(@$s_val)
+ if $c_ref eq 'Switch';
+ return scalar grep {$_=~/$c_val/} @$s_val
+ if $c_ref eq 'Regexp';
+ return scalar grep {$c_val->{$_}} @$s_val
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'Regexp')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $c_val=~/s_val/ if $c_ref eq "";
+ return scalar grep {$_=~/s_val/} @$c_val
+ if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return $s_val eq $c_val if $c_ref eq 'Regexp';
+ return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
+ if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'HASH')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ my $c_ref = ref $c_val;
+ return $s_val->{$c_val} if $c_ref eq "";
+ return scalar grep {$s_val->{$_}} @$c_val
+ if $c_ref eq 'ARRAY';
+ return $c_val->($s_val) if $c_ref eq 'CODE';
+ return $c_val->call($s_val) if $c_ref eq 'Switch';
+ return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
+ if $c_ref eq 'Regexp';
+ return $s_val==$c_val if $c_ref eq 'HASH';
+ return;
+ };
+ }
+ elsif ($s_ref eq 'Switch')
+ {
+ $::_S_W_I_T_C_H =
+ sub { my $c_val = $_[0];
+ return $s_val == $c_val if ref $c_val eq 'Switch';
+ return $s_val->call(@$c_val)
+ if ref $c_val eq 'ARRAY';
+ return $s_val->call($c_val);
+ };
+ }
+ else
+ {
+ croak "Cannot switch on $s_ref";
+ }
+ return 1;
+}
+
+sub case($) { local $SIG{__WARN__} = \&carp;
+ $::_S_W_I_T_C_H->(@_); }
+
+# IMPLEMENT __
+
+my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
+
+sub __() { $placeholder }
+
+sub __arg($)
+{
+ my $index = $_[0]+1;
+ bless { arity=>0, impl=>sub{$_[$index]} };
+}
+
+sub hosub(&@)
+{
+ # WRITE THIS
+}
+
+sub call
+{
+ my ($self,@args) = @_;
+ return $self->{impl}->(0,@args);
+}
+
+sub meta_bop(&)
+{
+ my ($op) = @_;
+ sub
+ {
+ my ($left, $right, $reversed) = @_;
+ ($right,$left) = @_ if $reversed;
+
+ my $rop = ref $right eq 'Switch'
+ ? $right
+ : bless { arity=>0, impl=>sub{$right} };
+
+ my $lop = ref $left eq 'Switch'
+ ? $left
+ : bless { arity=>0, impl=>sub{$left} };
+
+ my $arity = $lop->{arity} + $rop->{arity};
+
+ return bless {
+ arity => $arity,
+ impl => sub { my $start = shift;
+ return $op->($lop->{impl}->($start,@_),
+ $rop->{impl}->($start+$lop->{arity},@_));
+ }
+ };
+ };
+}
+
+sub meta_uop(&)
+{
+ my ($op) = @_;
+ sub
+ {
+ my ($left) = @_;
+
+ my $lop = ref $left eq 'Switch'
+ ? $left
+ : bless { arity=>0, impl=>sub{$left} };
+
+ my $arity = $lop->{arity};
+
+ return bless {
+ arity => $arity,
+ impl => sub { $op->($lop->{impl}->(@_)) }
+ };
+ };
+}
+
+
+use overload
+ "+" => meta_bop {$_[0] + $_[1]},
+ "-" => meta_bop {$_[0] - $_[1]},
+ "*" => meta_bop {$_[0] * $_[1]},
+ "/" => meta_bop {$_[0] / $_[1]},
+ "%" => meta_bop {$_[0] % $_[1]},
+ "**" => meta_bop {$_[0] ** $_[1]},
+ "<<" => meta_bop {$_[0] << $_[1]},
+ ">>" => meta_bop {$_[0] >> $_[1]},
+ "x" => meta_bop {$_[0] x $_[1]},
+ "." => meta_bop {$_[0] . $_[1]},
+ "<" => meta_bop {$_[0] < $_[1]},
+ "<=" => meta_bop {$_[0] <= $_[1]},
+ ">" => meta_bop {$_[0] > $_[1]},
+ ">=" => meta_bop {$_[0] >= $_[1]},
+ "==" => meta_bop {$_[0] == $_[1]},
+ "!=" => meta_bop {$_[0] != $_[1]},
+ "<=>" => meta_bop {$_[0] <=> $_[1]},
+ "lt" => meta_bop {$_[0] lt $_[1]},
+ "le" => meta_bop {$_[0] le $_[1]},
+ "gt" => meta_bop {$_[0] gt $_[1]},
+ "ge" => meta_bop {$_[0] ge $_[1]},
+ "eq" => meta_bop {$_[0] eq $_[1]},
+ "ne" => meta_bop {$_[0] ne $_[1]},
+ "cmp" => meta_bop {$_[0] cmp $_[1]},
+ "\&" => meta_bop {$_[0] & $_[1]},
+ "^" => meta_bop {$_[0] ^ $_[1]},
+ "|" => meta_bop {$_[0] | $_[1]},
+ "atan2" => meta_bop {atan2 $_[0], $_[1]},
+
+ "neg" => meta_uop {-$_[0]},
+ "!" => meta_uop {!$_[0]},
+ "~" => meta_uop {~$_[0]},
+ "cos" => meta_uop {cos $_[0]},
+ "sin" => meta_uop {sin $_[0]},
+ "exp" => meta_uop {exp $_[0]},
+ "abs" => meta_uop {abs $_[0]},
+ "log" => meta_uop {log $_[0]},
+ "sqrt" => meta_uop {sqrt $_[0]},
+ "bool" => sub { croak "Can't use && or || in expression containing __" },
+
+ # "&()" => sub { $_[0]->{impl} },
+
+ # "||" => meta_bop {$_[0] || $_[1]},
+ # "&&" => meta_bop {$_[0] && $_[1]},
+ # fallback => 1,
+ ;
+1;
+
+__END__
+
+
+=head1 NAME
+
+Switch - A switch statement for Perl
+
+=head1 SYNOPSIS
+
+ use Switch;
+
+ switch ($val) {
+ case 1 { print "number 1" }
+ case "a" { print "string a" }
+ case [1..10,42] { print "number in list" }
+ case (\@array) { print "number in list" }
+ case /\w+/ { print "pattern" }
+ case qr/\w+/ { print "pattern" }
+ case (\%hash) { print "entry in hash" }
+ case (\&sub) { print "arg to subroutine" }
+ else { print "previous case not true" }
+ }
+
+=head1 BACKGROUND
+
+[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
+and wherefores of this control structure]
+
+In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
+it is useful to generalize this notion of distributed conditional
+testing as far as possible. Specifically, the concept of "matching"
+between the switch value and the various case values need not be
+restricted to numeric (or string or referential) equality, as it is in other
+languages. Indeed, as Table 1 illustrates, Perl
+offers at least eighteen different ways in which two values could
+generate a match.
+
+ Table 1: Matching a switch value ($s) with a case value ($c)
+
+ Switch Case Type of Match Implied Matching Code
+ Value Value
+ ====== ===== ===================== =============
+
+ number same numeric or referential match if $s == $c;
+ or ref equality
+
+ object method result of method call match if $s->$c();
+ ref name match if defined $s->$c();
+ or ref
+
+ other other string equality match if $s eq $c;
+ non-ref non-ref
+ scalar scalar
+
+ string regexp pattern match match if $s =~ /$c/;
+
+ array scalar array entry existence match if 0<=$c && $c<@$s;
+ ref array entry definition match if defined $s->[$c];
+ array entry truth match if $s->[$c];
+
+ array array array intersection match if intersects(@$s, @$c);
+ ref ref (apply this table to
+ all pairs of elements
+ $s->[$i] and
+ $c->[$j])
+
+ array regexp array grep match if grep /$c/, @$s;
+ ref
+
+ hash scalar hash entry existence match if exists $s->{$c};
+ ref hash entry definition match if defined $s->{$c};
+ hash entry truth match if $s->{$c};
+
+ hash regexp hash grep match if grep /$c/, keys %$s;
+ ref
+
+ sub scalar return value defn match if defined $s->($c);
+ ref return value truth match if $s->($c);
+
+ sub array return value defn match if defined $s->(@$c);
+ ref ref return value truth match if $s->(@$c);
+
+
+In reality, Table 1 covers 31 alternatives, because only the equality and
+intersection tests are commutative; in all other cases, the roles of
+the C<$s> and C<$c> variables could be reversed to produce a
+different test. For example, instead of testing a single hash for
+the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
+one could test for the existence of a single key in a series of hashes
+(C<match if exists $c-E<gt>{$s}>).
+
+=head1 DESCRIPTION
+
+The Switch.pm module implements a generalized case mechanism that covers
+most (but not all) of the numerous possible combinations of switch and case
+values described above.
+
+The module augments the standard Perl syntax with two new control
+statements: C<switch> and C<case>. The C<switch> statement takes a
+single scalar argument of any type, specified in parentheses.
+C<switch> stores this value as the
+current switch value in a (localized) control variable.
+The value is followed by a block which may contain one or more
+Perl statements (including the C<case> statement described below).
+The block is unconditionally executed once the switch value has
+been cached.
+
+A C<case> statement takes a single scalar argument (in mandatory
+parentheses if it's a variable; otherwise the parens are optional) and
+selects the appropriate type of matching between that argument and the
+current switch value. The type of matching used is determined by the
+respective types of the switch value and the C<case> argument, as
+specified in Table 1. If the match is successful, the mandatory
+block associated with the C<case> statement is executed.
+
+In most other respects, the C<case> statement is semantically identical
+to an C<if> statement. For example, it can be followed by an C<else>
+clause, and can be used as a postfix statement qualifier.
+
+However, when a C<case> block has been executed control is automatically
+transferred to the statement after the immediately enclosing C<switch>
+block, rather than to the next statement within the block. In other
+words, the success of any C<case> statement prevents other cases in the
+same scope from executing. But see L<"Allowing fall-through"> below.
+
+Together these two new statements provide a fully generalized case
+mechanism:
+
+ use Switch;
+
+ # AND LATER...
+
+ %special = ( woohoo => 1, d'oh => 1 );
+
+ while (<>) {
+ chomp;
+ switch ($_) {
+ case (%special) { print "homer\n"; } # if $special{$_}
+ case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
+ case [1..9] { print "small num\n"; } # if $_ in [1..9]
+ case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
+ print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
+ }
+ }
+
+Note that C<switch>es can be nested within C<case> (or any other) blocks,
+and a series of C<case> statements can try different types of matches
+-- hash membership, pattern match, array intersection, simple equality,
+etc. -- against the same switch value.
+
+The use of intersection tests against an array reference is particularly
+useful for aggregating integral cases:
+
+ sub classify_digit
+ {
+ switch ($_[0]) { case 0 { return 'zero' }
+ case [2,4,6,8] { return 'even' }
+ case [1,3,5,7,9] { return 'odd' }
+ case /[A-F]/i { return 'hex' }
+ }
+ }
+
+
+=head2 Allowing fall-through
+
+Fall-though (trying another case after one has already succeeded)
+is usually a Bad Idea in a switch statement. However, this
+is Perl, not a police state, so there I<is> a way to do it, if you must.
+
+If a C<case> block executes an untargeted C<next>, control is
+immediately transferred to the statement I<after> the C<case> statement
+(i.e. usually another case), rather than out of the surrounding
+C<switch> block.
+
+For example:
+
+ switch ($val) {
+ case 1 { handle_num_1(); next } # and try next case...
+ case "1" { handle_str_1(); next } # and try next case...
+ case [0..9] { handle_num_any(); } # and we're done
+ case /\d/ { handle_dig_any(); next } # and try next case...
+ case /.*/ { handle_str_any(); next } # and try next case...
+ }
+
+If $val held the number C<1>, the above C<switch> block would call the
+first three C<handle_...> subroutines, jumping to the next case test
+each time it encountered a C<next>. After the third C<case> block
+was executed, control would jump to the end of the enclosing
+C<switch> block.
+
+On the other hand, if $val held C<10>, then only the last two C<handle_...>
+subroutines would be called.
+
+Note that this mechanism allows the notion of I<conditional fall-through>.
+For example:
+
+ switch ($val) {
+ case [0..9] { handle_num_any(); next if $val < 7; }
+ case /\d/ { handle_dig_any(); }
+ }
+
+If an untargeted C<last> statement is executed in a case block, this
+immediately transfers control out of the enclosing C<switch> block
+(in other words, there is an implicit C<last> at the end of each
+normal C<case> block). Thus the previous example could also have been
+written:
+
+ switch ($val) {
+ case [0..9] { handle_num_any(); last if $val >= 7; next; }
+ case /\d/ { handle_dig_any(); }
+ }
+
+
+=head2 Automating fall-through
+
+In situations where case fall-through should be the norm, rather than an
+exception, an endless succession of terminal C<next>s is tedious and ugly.
+Hence, it is possible to reverse the default behaviour by specifying
+the string "fallthrough" when importing the module. For example, the
+following code is equivalent to the first example in L<"Allowing fall-through">:
+
+ use Switch 'fallthrough';
+
+ switch ($val) {
+ case 1 { handle_num_1(); }
+ case "1" { handle_str_1(); }
+ case [0..9] { handle_num_any(); last }
+ case /\d/ { handle_dig_any(); }
+ case /.*/ { handle_str_any(); }
+ }
+
+Note the explicit use of a C<last> to preserve the non-fall-through
+behaviour of the third case.
+
+
+
+=head2 Alternative syntax
+
+Perl 6 will provide a built-in switch statement with essentially the
+same semantics as those offered by Switch.pm, but with a different
+pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
+C<case> will be pronounced C<when>. In addition, the C<when> statement
+will not require switch or case values to be parenthesized.
+
+This future syntax is also (largely) available via the Switch.pm module, by
+importing it with the argument C<"Perl6">. For example:
+
+ use Switch 'Perl6';
+
+ given ($val) {
+ when 1 { handle_num_1(); }
+ when ($str1) { handle_str_1(); }
+ when [0..9] { handle_num_any(); last }
+ when /\d/ { handle_dig_any(); }
+ when /.*/ { handle_str_any(); }
+ default { handle anything else; }
+ }
+
+Note that scalars still need to be parenthesized, since they would be
+ambiguous in Perl 5.
+
+Note too that you can mix and match both syntaxes by importing the module
+with:
+
+ use Switch 'Perl5', 'Perl6';
+
+
+=head2 Higher-order Operations
+
+One situation in which C<switch> and C<case> do not provide a good
+substitute for a cascaded C<if>, is where a switch value needs to
+be tested against a series of conditions. For example:
+
+ sub beverage {
+ switch (shift) {
+ case { $_[0] < 10 } { return 'milk' }
+ case { $_[0] < 20 } { return 'coke' }
+ case { $_[0] < 30 } { return 'beer' }
+ case { $_[0] < 40 } { return 'wine' }
+ case { $_[0] < 50 } { return 'malt' }
+ case { $_[0] < 60 } { return 'Moet' }
+ else { return 'milk' }
+ }
+ }
+
+(This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
+is the argument to the anonymous subroutine.)
+
+The need to specify each condition as a subroutine block is tiresome. To
+overcome this, when importing Switch.pm, a special "placeholder"
+subroutine named C<__> [sic] may also be imported. This subroutine
+converts (almost) any expression in which it appears to a reference to a
+higher-order function. That is, the expression:
+
+ use Switch '__';
+
+ __ < 2
+
+is equivalent to:
+
+ sub { $_[0] < 2 }
+
+With C<__>, the previous ugly case statements can be rewritten:
+
+ case __ < 10 { return 'milk' }
+ case __ < 20 { return 'coke' }
+ case __ < 30 { return 'beer' }
+ case __ < 40 { return 'wine' }
+ case __ < 50 { return 'malt' }
+ case __ < 60 { return 'Moet' }
+ else { return 'milk' }
+
+The C<__> subroutine makes extensive use of operator overloading to
+perform its magic. All operations involving __ are overloaded to
+produce an anonymous subroutine that implements a lazy version
+of the original operation.
+
+The only problem is that operator overloading does not allow the
+boolean operators C<&&> and C<||> to be overloaded. So a case statement
+like this:
+
+ case 0 <= __ && __ < 10 { return 'digit' }
+
+doesn't act as expected, because when it is
+executed, it constructs two higher order subroutines
+and then treats the two resulting references as arguments to C<&&>:
+
+ sub { 0 <= $_[0] } && sub { $_[0] < 10 }
+
+This boolean expression is inevitably true, since both references are
+non-false. Fortunately, the overloaded C<'bool'> operator catches this
+situation and flags it as an error.
+
+=head1 DEPENDENCIES
+
+The module is implemented using Filter::Util::Call and Text::Balanced
+and requires both these modules to be installed.
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org). This module is now maintained by Rafael
+Garcia-Suarez (rgarciasuarez@gmail.com) and more generally by the Perl 5
+Porters (perl5-porters@perl.org), as part of the Perl core.
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 LIMITATIONS
+
+Due to the heuristic nature of Switch.pm's source parsing, the presence of
+regexes with embedded newlines that are specified with raw C</.../>
+delimiters and don't have a modifier C<//x> are indistinguishable from
+code chunks beginning with the division operator C</>. As a workaround
+you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
+of regexes specified with raw C<?...?> delimiters may cause mysterious
+errors. The workaround is to use C<m?...?> instead.
+
+Due to the way source filters work in Perl, you can't use Switch inside
+an string C<eval>.
+
+If your source file is longer then 1 million characters and you have a
+switch statement that crosses the 1 million (or 2 million, etc.)
+character boundary you will get mysterious errors. The workaround is to
+use smaller source files.
+
+=head1 COPYRIGHT
+
+ Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl/lib/Symbol.pm b/Master/tlpkg/tlperl/lib/Symbol.pm
new file mode 100644
index 00000000000..1e408b59f71
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Symbol.pm
@@ -0,0 +1,170 @@
+package Symbol;
+
+=head1 NAME
+
+Symbol - manipulate Perl symbols and their names
+
+=head1 SYNOPSIS
+
+ use Symbol;
+
+ $sym = gensym;
+ open($sym, "filename");
+ $_ = <$sym>;
+ # etc.
+
+ ungensym $sym; # no effect
+
+ # replace *FOO{IO} handle but not $FOO, %FOO, etc.
+ *FOO = geniosym;
+
+ print qualify("x"), "\n"; # "main::x"
+ print qualify("x", "FOO"), "\n"; # "FOO::x"
+ print qualify("BAR::x"), "\n"; # "BAR::x"
+ print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
+ print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
+ print qualify(\*x), "\n"; # returns \*x
+ print qualify(\*x, "FOO"), "\n"; # returns \*x
+
+ use strict refs;
+ print { qualify_to_ref $fh } "foo!\n";
+ $ref = qualify_to_ref $name, $pkg;
+
+ use Symbol qw(delete_package);
+ delete_package('Foo::Bar');
+ print "deleted\n" unless exists $Foo::{'Bar::'};
+
+=head1 DESCRIPTION
+
+C<Symbol::gensym> creates an anonymous glob and returns a reference
+to it. Such a glob reference can be used as a file or directory
+handle.
+
+For backward compatibility with older implementations that didn't
+support anonymous globs, C<Symbol::ungensym> is also provided.
+But it doesn't do anything.
+
+C<Symbol::geniosym> creates an anonymous IO handle. This can be
+assigned into an existing glob without affecting the non-IO portions
+of the glob.
+
+C<Symbol::qualify> turns unqualified symbol names into qualified
+variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
+second parameter, C<qualify> uses it as the default package;
+otherwise, it uses the package of its caller. Regardless, global
+variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
+"main::".
+
+Qualification applies only to symbol names (strings). References are
+left unchanged under the assumption that they are glob references,
+which are qualified by their nature.
+
+C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
+returns a glob ref rather than a symbol name, so you can use the result
+even if C<use strict 'refs'> is in effect.
+
+C<Symbol::delete_package> wipes out a whole package namespace. Note
+this routine is not exported by default--you may want to import it
+explicitly.
+
+=head1 BUGS
+
+C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
+lives in the specified package. Since perl, for performance reasons, does not
+perform a symbol table lookup each time a function is called or a global
+variable is accessed, some code that has already been loaded and that makes use
+of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
+you reload the C<Foo> module afterwards.
+
+=cut
+
+BEGIN { require 5.005; }
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
+@EXPORT_OK = qw(delete_package geniosym);
+
+$VERSION = '1.07';
+
+my $genpkg = "Symbol::";
+my $genseq = 0;
+
+my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
+
+#
+# Note that we never _copy_ the glob; we just make a ref to it.
+# If we did copy it, then SVf_FAKE would be set on the copy, and
+# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
+#
+sub gensym () {
+ my $name = "GEN" . $genseq++;
+ my $ref = \*{$genpkg . $name};
+ delete $$genpkg{$name};
+ $ref;
+}
+
+sub geniosym () {
+ my $sym = gensym();
+ # force the IO slot to be filled
+ select(select $sym);
+ *$sym{IO};
+}
+
+sub ungensym ($) {}
+
+sub qualify ($;$) {
+ my ($name) = @_;
+ if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
+ my $pkg;
+ # Global names: special character, "^xyz", or other.
+ if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
+ # RGS 2001-11-05 : translate leading ^X to control-char
+ $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
+ $pkg = "main";
+ }
+ else {
+ $pkg = (@_ > 1) ? $_[1] : caller;
+ }
+ $name = $pkg . "::" . $name;
+ }
+ $name;
+}
+
+sub qualify_to_ref ($;$) {
+ return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
+}
+
+#
+# of Safe.pm lineage
+#
+sub delete_package ($) {
+ my $pkg = shift;
+
+ # expand to full symbol table name if needed
+
+ unless ($pkg =~ /^main::.*::$/) {
+ $pkg = "main$pkg" if $pkg =~ /^::/;
+ $pkg = "main::$pkg" unless $pkg =~ /^main::/;
+ $pkg .= '::' unless $pkg =~ /::$/;
+ }
+
+ my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ my $stem_symtab = *{$stem}{HASH};
+ return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
+
+
+ # free all the symbols in the package
+
+ my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
+ foreach my $name (keys %$leaf_symtab) {
+ undef *{$pkg . $name};
+ }
+
+ # delete the symbol table
+
+ %$leaf_symtab = ();
+ delete $stem_symtab->{$leaf};
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Test.pm b/Master/tlpkg/tlperl/lib/Test.pm
new file mode 100644
index 00000000000..6ab54ab5601
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test.pm
@@ -0,0 +1,954 @@
+
+require 5.004;
+package Test;
+
+use strict;
+
+use Carp;
+use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
+ qw($TESTOUT $TESTERR %Program_Lines $told_about_diff
+ $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish
+ );
+
+# In case a test is run in a persistent environment.
+sub _reset_globals {
+ %todo = ();
+ %history = ();
+ @FAILDETAIL = ();
+ $ntest = 1;
+ $TestLevel = 0; # how many extra stack frames to skip
+ $planned = 0;
+}
+
+$VERSION = '1.25_02';
+require Exporter;
+@ISA=('Exporter');
+
+@EXPORT = qw(&plan &ok &skip);
+@EXPORT_OK = qw($ntest $TESTOUT $TESTERR);
+
+$|=1;
+$TESTOUT = *STDOUT{IO};
+$TESTERR = *STDERR{IO};
+
+# Use of this variable is strongly discouraged. It is set mainly to
+# help test coverage analyzers know which test is running.
+$ENV{REGRESSION_TEST} = $0;
+
+
+=head1 NAME
+
+Test - provides a simple framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use strict;
+ use Test;
+
+ # use a BEGIN block so we print our plan before MyModule is loaded
+ BEGIN { plan tests => 14, todo => [3,4] }
+
+ # load your module...
+ use MyModule;
+
+ # Helpful notes. All note-lines must start with a "#".
+ print "# I'm testing MyModule version $MyModule::VERSION\n";
+
+ ok(0); # failure
+ ok(1); # success
+
+ ok(0); # ok, expected failure (see todo list, above)
+ ok(1); # surprise success!
+
+ ok(0,1); # failure: '0' ne '1'
+ ok('broke','fixed'); # failure: 'broke' ne 'fixed'
+ ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
+ ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
+
+ ok(sub { 1+1 }, 2); # success: '2' eq '2'
+ ok(sub { 1+1 }, 3); # failure: '2' ne '3'
+
+ my @list = (0,0);
+ ok @list, 3, "\@list=".join(',',@list); #extra notes
+ ok 'segmentation fault', '/(?i)success/'; #regex match
+
+ skip(
+ $^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip
+ $foo, $bar # arguments just like for ok(...)
+ );
+ skip(
+ $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip
+ $foo, $bar # arguments just like for ok(...)
+ );
+
+=head1 DESCRIPTION
+
+This module simplifies the task of writing test files for Perl modules,
+such that their output is in the format that
+L<Test::Harness|Test::Harness> expects to see.
+
+=head1 QUICK START GUIDE
+
+To write a test for your new (and probably not even done) module, create
+a new file called F<t/test.t> (in a new F<t> directory). If you have
+multiple test files, to test the "foo", "bar", and "baz" feature sets,
+then feel free to call your files F<t/foo.t>, F<t/bar.t>, and
+F<t/baz.t>
+
+=head2 Functions
+
+This module defines three public functions, C<plan(...)>, C<ok(...)>,
+and C<skip(...)>. By default, all three are exported by
+the C<use Test;> statement.
+
+=over 4
+
+=item C<plan(...)>
+
+ BEGIN { plan %theplan; }
+
+This should be the first thing you call in your test script. It
+declares your testing plan, how many there will be, if any of them
+should be allowed to fail, and so on.
+
+Typical usage is just:
+
+ use Test;
+ BEGIN { plan tests => 23 }
+
+These are the things that you can put in the parameters to plan:
+
+=over
+
+=item C<tests =E<gt> I<number>>
+
+The number of tests in your script.
+This means all ok() and skip() calls.
+
+=item C<todo =E<gt> [I<1,5,14>]>
+
+A reference to a list of tests which are allowed to fail.
+See L</TODO TESTS>.
+
+=item C<onfail =E<gt> sub { ... }>
+
+=item C<onfail =E<gt> \&some_sub>
+
+A subroutine reference to be run at the end of the test script, if
+any of the tests fail. See L</ONFAIL>.
+
+=back
+
+You must call C<plan(...)> once and only once. You should call it
+in a C<BEGIN {...}> block, like so:
+
+ BEGIN { plan tests => 23 }
+
+=cut
+
+sub plan {
+ croak "Test::plan(%args): odd number of arguments" if @_ & 1;
+ croak "Test::plan(): should not be called more than once" if $planned;
+
+ local($\, $,); # guard against -l and other things that screw with
+ # print
+
+ _reset_globals();
+
+ _read_program( (caller)[1] );
+
+ my $max=0;
+ while (@_) {
+ my ($k,$v) = splice(@_, 0, 2);
+ if ($k =~ /^test(s)?$/) { $max = $v; }
+ elsif ($k eq 'todo' or
+ $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
+ elsif ($k eq 'onfail') {
+ ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
+ $ONFAIL = $v;
+ }
+ else { carp "Test::plan(): skipping unrecognized directive '$k'" }
+ }
+ my @todo = sort { $a <=> $b } keys %todo;
+ if (@todo) {
+ print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
+ } else {
+ print $TESTOUT "1..$max\n";
+ }
+ ++$planned;
+ print $TESTOUT "# Running under perl version $] for $^O",
+ (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
+
+ print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
+ if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
+
+ print $TESTOUT "# MacPerl version $MacPerl::Version\n"
+ if defined $MacPerl::Version;
+
+ printf $TESTOUT
+ "# Current time local: %s\n# Current time GMT: %s\n",
+ scalar(localtime($^T)), scalar(gmtime($^T));
+
+ print $TESTOUT "# Using Test.pm version $VERSION\n";
+
+ # Retval never used:
+ return undef;
+}
+
+sub _read_program {
+ my($file) = shift;
+ return unless defined $file and length $file
+ and -e $file and -f _ and -r _;
+ open(SOURCEFILE, "<$file") || return;
+ $Program_Lines{$file} = [<SOURCEFILE>];
+ close(SOURCEFILE);
+
+ foreach my $x (@{$Program_Lines{$file}})
+ { $x =~ tr/\cm\cj\n\r//d }
+
+ unshift @{$Program_Lines{$file}}, '';
+ return 1;
+}
+
+=begin _private
+
+=item B<_to_value>
+
+ my $value = _to_value($input);
+
+Converts an C<ok> parameter to its value. Typically this just means
+running it, if it's a code reference. You should run all inputted
+values through this.
+
+=cut
+
+sub _to_value {
+ my ($v) = @_;
+ return ref $v eq 'CODE' ? $v->() : $v;
+}
+
+sub _quote {
+ my $str = $_[0];
+ return "<UNDEF>" unless defined $str;
+ $str =~ s/\\/\\\\/g;
+ $str =~ s/"/\\"/g;
+ $str =~ s/\a/\\a/g;
+ $str =~ s/[\b]/\\b/g;
+ $str =~ s/\e/\\e/g;
+ $str =~ s/\f/\\f/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/\t/\\t/g;
+ $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
+ $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
+ $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
+ #if( $_[1] ) {
+ # substr( $str , 218-3 ) = "..."
+ # if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC};
+ #}
+ return qq("$str");
+}
+
+
+=end _private
+
+=item C<ok(...)>
+
+ ok(1 + 1 == 2);
+ ok($have, $expect);
+ ok($have, $expect, $diagnostics);
+
+This function is the reason for C<Test>'s existence. It's
+the basic function that
+handles printing "C<ok>" or "C<not ok>", along with the
+current test number. (That's what C<Test::Harness> wants to see.)
+
+In its most basic usage, C<ok(...)> simply takes a single scalar
+expression. If its value is true, the test passes; if false,
+the test fails. Examples:
+
+ # Examples of ok(scalar)
+
+ ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2
+ ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
+ ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
+ # 'Armondo'
+ ok( @a == @b ); # ok if @a and @b are the same length
+
+The expression is evaluated in scalar context. So the following will
+work:
+
+ ok( @stuff ); # ok if @stuff has any elements
+ ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
+ # defined.
+
+A special case is if the expression is a subroutine reference (in either
+C<sub {...}> syntax or C<\&foo> syntax). In
+that case, it is executed and its value (true or false) determines if
+the test passes or fails. For example,
+
+ ok( sub { # See whether sleep works at least passably
+ my $start_time = time;
+ sleep 5;
+ time() - $start_time >= 4
+ });
+
+In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two
+scalar values to see if they match. They match if both are undefined,
+or if I<arg2> is a regex that matches I<arg1>, or if they compare equal
+with C<eq>.
+
+ # Example of ok(scalar, scalar)
+
+ ok( "this", "that" ); # not ok, 'this' ne 'that'
+ ok( "", undef ); # not ok, "" is defined
+
+The second argument is considered a regex if it is either a regex
+object or a string that looks like a regex. Regex objects are
+constructed with the qr// operator in recent versions of perl. A
+string is considered to look like a regex if its first and last
+characters are "/", or if the first character is "m"
+and its second and last characters are both the
+same non-alphanumeric non-whitespace character. These regexp
+
+Regex examples:
+
+ ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/
+ ok( 'JaffO', 'm|Jaff|' ); # ok, 'JaffO' =~ m|Jaff|
+ ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/;
+ ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
+
+If either (or both!) is a subroutine reference, it is run and used
+as the value for comparing. For example:
+
+ ok sub {
+ open(OUT, ">x.dat") || die $!;
+ print OUT "\x{e000}";
+ close OUT;
+ my $bytecount = -s 'x.dat';
+ unlink 'x.dat' or warn "Can't unlink : $!";
+ return $bytecount;
+ },
+ 4
+ ;
+
+The above test passes two values to C<ok(arg1, arg2)> -- the first
+a coderef, and the second is the number 4. Before C<ok> compares them,
+it calls the coderef, and uses its return value as the real value of
+this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up
+testing C<4 eq 4>. Since that's true, this test passes.
+
+Finally, you can append an optional third argument, in
+C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that
+will be printed if the test fails. This should be some useful
+information about the test, pertaining to why it failed, and/or
+a description of the test. For example:
+
+ ok( grep($_ eq 'something unique', @stuff), 1,
+ "Something that should be unique isn't!\n".
+ '@stuff = '.join ', ', @stuff
+ );
+
+Unfortunately, a note cannot be used with the single argument
+style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then
+C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably
+end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want!
+
+All of the above special cases can occasionally cause some
+problems. See L</BUGS and CAVEATS>.
+
+=cut
+
+# A past maintainer of this module said:
+# <<ok(...)'s special handling of subroutine references is an unfortunate
+# "feature" that can't be removed due to compatibility.>>
+#
+
+sub ok ($;$$) {
+ croak "ok: plan before you test!" if !$planned;
+
+ local($\,$,); # guard against -l and other things that screw with
+ # print
+
+ my ($pkg,$file,$line) = caller($TestLevel);
+ my $repetition = ++$history{"$file:$line"};
+ my $context = ("$file at line $line".
+ ($repetition > 1 ? " fail \#$repetition" : ''));
+
+ # Are we comparing two values?
+ my $compare = 0;
+
+ my $ok=0;
+ my $result = _to_value(shift);
+ my ($expected, $isregex, $regex);
+ if (@_ == 0) {
+ $ok = $result;
+ } else {
+ $compare = 1;
+ $expected = _to_value(shift);
+ if (!defined $expected) {
+ $ok = !defined $result;
+ } elsif (!defined $result) {
+ $ok = 0;
+ } elsif (ref($expected) eq 'Regexp') {
+ $ok = $result =~ /$expected/;
+ $regex = $expected;
+ } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
+ (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
+ $ok = $result =~ /$regex/;
+ } else {
+ $ok = $result eq $expected;
+ }
+ }
+ my $todo = $todo{$ntest};
+ if ($todo and $ok) {
+ $context .= ' TODO?!' if $todo;
+ print $TESTOUT "ok $ntest # ($context)\n";
+ } else {
+ # Issuing two seperate prints() causes problems on VMS.
+ if (!$ok) {
+ print $TESTOUT "not ok $ntest\n";
+ }
+ else {
+ print $TESTOUT "ok $ntest\n";
+ }
+
+ $ok or _complain($result, $expected,
+ {
+ 'repetition' => $repetition, 'package' => $pkg,
+ 'result' => $result, 'todo' => $todo,
+ 'file' => $file, 'line' => $line,
+ 'context' => $context, 'compare' => $compare,
+ @_ ? ('diagnostic' => _to_value(shift)) : (),
+ });
+
+ }
+ ++ $ntest;
+ $ok;
+}
+
+
+sub _complain {
+ my($result, $expected, $detail) = @_;
+ $$detail{expected} = $expected if defined $expected;
+
+ # Get the user's diagnostic, protecting against multi-line
+ # diagnostics.
+ my $diag = $$detail{diagnostic};
+ $diag =~ s/\n/\n#/g if defined $diag;
+
+ $$detail{context} .= ' *TODO*' if $$detail{todo};
+ if (!$$detail{compare}) {
+ if (!$diag) {
+ print $TESTERR "# Failed test $ntest in $$detail{context}\n";
+ } else {
+ print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n";
+ }
+ } else {
+ my $prefix = "Test $ntest";
+
+ print $TESTERR "# $prefix got: " . _quote($result) .
+ " ($$detail{context})\n";
+ $prefix = ' ' x (length($prefix) - 5);
+ my $expected_quoted = (defined $$detail{regex})
+ ? 'qr{'.($$detail{regex}).'}' : _quote($expected);
+
+ print $TESTERR "# $prefix Expected: $expected_quoted",
+ $diag ? " ($diag)" : (), "\n";
+
+ _diff_complain( $result, $expected, $detail, $prefix )
+ if defined($expected) and 2 < ($expected =~ tr/\n//);
+ }
+
+ if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) {
+ print $TESTERR
+ "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n"
+ if $Program_Lines{ $$detail{file} }[ $$detail{line} ]
+ =~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative
+
+ undef $Program_Lines{ $$detail{file} }[ $$detail{line} ];
+ # So we won't repeat it.
+ }
+
+ push @FAILDETAIL, $detail;
+ return;
+}
+
+
+
+sub _diff_complain {
+ my($result, $expected, $detail, $prefix) = @_;
+ return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF};
+ return _diff_complain_algdiff(@_)
+ if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; };
+
+ $told_about_diff++ or print $TESTERR <<"EOT";
+# $prefix (Install the Algorithm::Diff module to have differences in multiline
+# $prefix output explained. You might also set the PERL_TEST_DIFF environment
+# $prefix variable to run a diff program on the output.)
+EOT
+ ;
+ return;
+}
+
+
+
+sub _diff_complain_external {
+ my($result, $expected, $detail, $prefix) = @_;
+ my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?";
+
+ require File::Temp;
+ my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX");
+ my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX");
+ unless ($got_fh && $exp_fh) {
+ warn "Can't get tempfiles";
+ return;
+ }
+
+ print $got_fh $result;
+ print $exp_fh $expected;
+ if (close($got_fh) && close($exp_fh)) {
+ my $diff_cmd = "$diff $exp_filename $got_filename";
+ print $TESTERR "#\n# $prefix $diff_cmd\n";
+ if (open(DIFF, "$diff_cmd |")) {
+ local $_;
+ while (<DIFF>) {
+ print $TESTERR "# $prefix $_";
+ }
+ close(DIFF);
+ }
+ else {
+ warn "Can't run diff: $!";
+ }
+ } else {
+ warn "Can't write to tempfiles: $!";
+ }
+ unlink($got_filename);
+ unlink($exp_filename);
+ return;
+}
+
+
+
+sub _diff_complain_algdiff {
+ my($result, $expected, $detail, $prefix) = @_;
+
+ my @got = split(/^/, $result);
+ my @exp = split(/^/, $expected);
+
+ my $diff_kind;
+ my @diff_lines;
+
+ my $diff_flush = sub {
+ return unless $diff_kind;
+
+ my $count_lines = @diff_lines;
+ my $s = $count_lines == 1 ? "" : "s";
+ my $first_line = $diff_lines[0][0] + 1;
+
+ print $TESTERR "# $prefix ";
+ if ($diff_kind eq "GOT") {
+ print $TESTERR "Got $count_lines extra line$s at line $first_line:\n";
+ for my $i (@diff_lines) {
+ print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
+ }
+ } elsif ($diff_kind eq "EXP") {
+ if ($count_lines > 1) {
+ my $last_line = $diff_lines[-1][0] + 1;
+ print $TESTERR "Lines $first_line-$last_line are";
+ }
+ else {
+ print $TESTERR "Line $first_line is";
+ }
+ print $TESTERR " missing:\n";
+ for my $i (@diff_lines) {
+ print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
+ }
+ } elsif ($diff_kind eq "CH") {
+ if ($count_lines > 1) {
+ my $last_line = $diff_lines[-1][0] + 1;
+ print $TESTERR "Lines $first_line-$last_line are";
+ }
+ else {
+ print $TESTERR "Line $first_line is";
+ }
+ print $TESTERR " changed:\n";
+ for my $i (@diff_lines) {
+ print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
+ print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
+ }
+ }
+
+ # reset
+ $diff_kind = undef;
+ @diff_lines = ();
+ };
+
+ my $diff_collect = sub {
+ my $kind = shift;
+ &$diff_flush() if $diff_kind && $diff_kind ne $kind;
+ $diff_kind = $kind;
+ push(@diff_lines, [@_]);
+ };
+
+
+ Algorithm::Diff::traverse_balanced(
+ \@got, \@exp,
+ {
+ DISCARD_A => sub { &$diff_collect("GOT", @_) },
+ DISCARD_B => sub { &$diff_collect("EXP", @_) },
+ CHANGE => sub { &$diff_collect("CH", @_) },
+ MATCH => sub { &$diff_flush() },
+ },
+ );
+ &$diff_flush();
+
+ return;
+}
+
+
+
+
+#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~
+
+
+=item C<skip(I<skip_if_true>, I<args...>)>
+
+This is used for tests that under some conditions can be skipped. It's
+basically equivalent to:
+
+ if( $skip_if_true ) {
+ ok(1);
+ } else {
+ ok( args... );
+ }
+
+...except that the C<ok(1)> emits not just "C<ok I<testnum>>" but
+actually "C<ok I<testnum> # I<skip_if_true_value>>".
+
+The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if
+this test isn't skipped.
+
+Example usage:
+
+ my $if_MSWin =
+ $^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
+
+ # A test to be skipped if under MSWin (i.e., run except under MSWin)
+ skip($if_MSWin, thing($foo), thing($bar) );
+
+Or, going the other way:
+
+ my $unless_MSWin =
+ $^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin';
+
+ # A test to be skipped unless under MSWin (i.e., run only under MSWin)
+ skip($unless_MSWin, thing($foo), thing($bar) );
+
+The tricky thing to remember is that the first parameter is true if
+you want to I<skip> the test, not I<run> it; and it also doubles as a
+note about why it's being skipped. So in the first codeblock above, read
+the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is
+C<thing($bar)>" or for the second case, "skip unless MSWin...".
+
+Also, when your I<skip_if_reason> string is true, it really should (for
+backwards compatibility with older Test.pm versions) start with the
+string "Skip", as shown in the above examples.
+
+Note that in the above cases, C<thing($foo)> and C<thing($bar)>
+I<are> evaluated -- but as long as the C<skip_if_true> is true,
+then we C<skip(...)> just tosses out their value (i.e., not
+bothering to treat them like values to C<ok(...)>. But if
+you need to I<not> eval the arguments when skipping the
+test, use
+this format:
+
+ skip( $unless_MSWin,
+ sub {
+ # This code returns true if the test passes.
+ # (But it doesn't even get called if the test is skipped.)
+ thing($foo) eq thing($bar)
+ }
+ );
+
+or even this, which is basically equivalent:
+
+ skip( $unless_MSWin,
+ sub { thing($foo) }, sub { thing($bar) }
+ );
+
+That is, both are like this:
+
+ if( $unless_MSWin ) {
+ ok(1); # but it actually appends "# $unless_MSWin"
+ # so that Test::Harness can tell it's a skip
+ } else {
+ # Not skipping, so actually call and evaluate...
+ ok( sub { thing($foo) }, sub { thing($bar) } );
+ }
+
+=cut
+
+sub skip ($;$$$) {
+ local($\, $,); # guard against -l and other things that screw with
+ # print
+
+ my $whyskip = _to_value(shift);
+ if (!@_ or $whyskip) {
+ $whyskip = '' if $whyskip =~ m/^\d+$/;
+ $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old
+ # versions required the reason
+ # to start with 'skip'
+ # We print in one shot for VMSy reasons.
+ my $ok = "ok $ntest # skip";
+ $ok .= " $whyskip" if length $whyskip;
+ $ok .= "\n";
+ print $TESTOUT $ok;
+ ++ $ntest;
+ return 1;
+ } else {
+ # backwards compatibility (I think). skip() used to be
+ # called like ok(), which is weird. I haven't decided what to do with
+ # this yet.
+# warn <<WARN if $^W;
+#This looks like a skip() using the very old interface. Please upgrade to
+#the documented interface as this has been deprecated.
+#WARN
+
+ local($TestLevel) = $TestLevel+1; #to ignore this stack frame
+ return &ok(@_);
+ }
+}
+
+=back
+
+=cut
+
+END {
+ $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
+}
+
+1;
+__END__
+
+=head1 TEST TYPES
+
+=over 4
+
+=item * NORMAL TESTS
+
+These tests are expected to succeed. Usually, most or all of your tests
+are in this category. If a normal test doesn't succeed, then that
+means that something is I<wrong>.
+
+=item * SKIPPED TESTS
+
+The C<skip(...)> function is for tests that might or might not be
+possible to run, depending
+on the availability of platform-specific features. The first argument
+should evaluate to true (think "yes, please skip") if the required
+feature is I<not> available. After the first argument, C<skip(...)> works
+exactly the same way as C<ok(...)> does.
+
+=item * TODO TESTS
+
+TODO tests are designed for maintaining an B<executable TODO list>.
+These tests are I<expected to fail.> If a TODO test does succeed,
+then the feature in question shouldn't be on the TODO list, now
+should it?
+
+Packages should NOT be released with succeeding TODO tests. As soon
+as a TODO test starts working, it should be promoted to a normal test,
+and the newly working feature should be documented in the release
+notes or in the change log.
+
+=back
+
+=head1 ONFAIL
+
+ BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
+
+Although test failures should be enough, extra diagnostics can be
+triggered at the end of a test run. C<onfail> is passed an array ref
+of hash refs that describe each test failure. Each hash will contain
+at least the following fields: C<package>, C<repetition>, and
+C<result>. (You shouldn't rely on any other fields being present.) If the test
+had an expected value or a diagnostic (or "note") string, these will also be
+included.
+
+The I<optional> C<onfail> hook might be used simply to print out the
+version of your package and/or how to report problems. It might also
+be used to generate extremely sophisticated diagnostics for a
+particularly bizarre test failure. However it's not a panacea. Core
+dumps or other unrecoverable errors prevent the C<onfail> hook from
+running. (It is run inside an C<END> block.) Besides, C<onfail> is
+probably over-kill in most cases. (Your test code should be simpler
+than the code it is testing, yes?)
+
+
+=head1 BUGS and CAVEATS
+
+=over
+
+=item *
+
+C<ok(...)>'s special handing of strings which look like they might be
+regexes can also cause unexpected behavior. An innocent:
+
+ ok( $fileglob, '/path/to/some/*stuff/' );
+
+will fail, since Test.pm considers the second argument to be a regex!
+The best bet is to use the one-argument form:
+
+ ok( $fileglob eq '/path/to/some/*stuff/' );
+
+=item *
+
+C<ok(...)>'s use of string C<eq> can sometimes cause odd problems
+when comparing
+numbers, especially if you're casting a string to a number:
+
+ $foo = "1.0";
+ ok( $foo, 1 ); # not ok, "1.0" ne 1
+
+Your best bet is to use the single argument form:
+
+ ok( $foo == 1 ); # ok "1.0" == 1
+
+=item *
+
+As you may have inferred from the above documentation and examples,
+C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is
+C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar>
+to compare the I<size> of the two arrays. But don't be fooled into
+thinking that C<ok @foo, @bar> means a comparison of the contents of two
+arrays -- you're comparing I<just> the number of elements of each. It's
+so easy to make that mistake in reading C<ok @foo, @bar> that you might
+want to be very explicit about it, and instead write C<ok scalar(@foo),
+scalar(@bar)>.
+
+=item *
+
+This almost definitely doesn't do what you expect:
+
+ ok $thingy->can('some_method');
+
+Why? Because C<can> returns a coderef to mean "yes it can (and the
+method is this...)", and then C<ok> sees a coderef and thinks you're
+passing a function that you want it to call and consider the truth of
+the result of! I.e., just like:
+
+ ok $thingy->can('some_method')->();
+
+What you probably want instead is this:
+
+ ok $thingy->can('some_method') && 1;
+
+If the C<can> returns false, then that is passed to C<ok>. If it
+returns true, then the larger expression S<< C<<
+$thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as
+a simple signal of success, as you would expect.
+
+
+=item *
+
+The syntax for C<skip> is about the only way it can be, but it's still
+quite confusing. Just start with the above examples and you'll
+be okay.
+
+Moreover, users may expect this:
+
+ skip $unless_mswin, foo($bar), baz($quux);
+
+to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being
+skipped. But in reality, they I<are> evaluated, but C<skip> just won't
+bother comparing them if C<$unless_mswin> is true.
+
+You could do this:
+
+ skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)};
+
+But that's not terribly pretty. You may find it simpler or clearer in
+the long run to just do things like this:
+
+ if( $^O =~ m/MSWin/ ) {
+ print "# Yay, we're under $^O\n";
+ ok foo($bar), baz($quux);
+ ok thing($whatever), baz($stuff);
+ ok blorp($quux, $whatever);
+ ok foo($barzbarz), thang($quux);
+ } else {
+ print "# Feh, we're under $^O. Watch me skip some tests...\n";
+ for(1 .. 4) { skip "Skip unless under MSWin" }
+ }
+
+But be quite sure that C<ok> is called exactly as many times in the
+first block as C<skip> is called in the second block.
+
+=back
+
+
+=head1 ENVIRONMENT
+
+If C<PERL_TEST_DIFF> environment variable is set, it will be used as a
+command for comparing unexpected multiline results. If you have GNU
+diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>.
+If you don't have a suitable program, you might install the
+C<Text::Diff> module and then set C<PERL_TEST_DIFF> to be C<perl
+-MText::Diff -e 'print diff(@ARGV)'>. If C<PERL_TEST_DIFF> isn't set
+but the C<Algorithm::Diff> module is available, then it will be used
+to show the differences in multiline results.
+
+=for comment
+If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but
+expected 'something_else'" readings for long multiline output values aren't
+truncated at about the 230th column, as they normally could be in some
+cases. Normally you won't need to use this, unless you were carefully
+parsing the output of your test programs.
+
+
+=head1 NOTE
+
+A past developer of this module once said that it was no longer being
+actively developed. However, rumors of its demise were greatly
+exaggerated. Feedback and suggestions are quite welcome.
+
+Be aware that the main value of this module is its simplicity. Note
+that there are already more ambitious modules out there, such as
+L<Test::More> and L<Test::Unit>.
+
+Some earlier versions of this module had docs with some confusing
+typos in the description of C<skip(...)>.
+
+
+=head1 SEE ALSO
+
+L<Test::Harness>
+
+L<Test::Simple>, L<Test::More>, L<Devel::Cover>
+
+L<Test::Builder> for building your own testing library.
+
+L<Test::Unit> is an interesting XUnit-style testing library.
+
+L<Test::Inline> and L<SelfTest> let you embed tests in code.
+
+
+=head1 AUTHOR
+
+Copyright (c) 1998-2000 Joshua Nathaniel Pritikin.
+
+Copyright (c) 2001-2002 Michael G. Schwern.
+
+Copyright (c) 2002-2004 Sean M. Burke.
+
+Current maintainer: Jesse Vincent. E<lt>jesse@bestpractical.comE<gt>
+
+This package is free software and is provided "as is" without express
+or implied warranty. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+
+=cut
+
+# "Your mistake was a hidden intention."
+# -- /Oblique Strategies/, Brian Eno and Peter Schmidt
diff --git a/Master/tlpkg/tlperl/lib/Thread.pm b/Master/tlpkg/tlperl/lib/Thread.pm
new file mode 100644
index 00000000000..247f90ccc9e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Thread.pm
@@ -0,0 +1,273 @@
+package Thread;
+
+use strict;
+use warnings;
+no warnings 'redefine';
+
+our $VERSION = '3.02';
+$VERSION = eval $VERSION;
+
+BEGIN {
+ use Config;
+ if (! $Config{useithreads}) {
+ die("This Perl not built to support threads\n");
+ }
+}
+
+use threads 'yield';
+use threads::shared;
+
+require Exporter;
+our @ISA = qw(Exporter threads);
+our @EXPORT = qw(cond_wait cond_broadcast cond_signal);
+our @EXPORT_OK = qw(async yield);
+
+sub async (&;@) { return Thread->new(shift); }
+
+sub done { return ! shift->is_running(); }
+
+sub eval { die("'eval' not implemented with 'ithreads'\n"); };
+sub flags { die("'flags' not implemented with 'ithreads'\n"); };
+
+1;
+
+__END__
+
+=head1 NAME
+
+Thread - Manipulate threads in Perl (for old code only)
+
+=head1 DEPRECATED
+
+The C<Thread> module served as the frontend to the old-style thread model,
+called I<5005threads>, that was introduced in release 5.005. That model was
+deprecated, and has been removed in version 5.10.
+
+For old code and interim backwards compatibility, the C<Thread> module has
+been reworked to function as a frontend for the new interpreter threads
+(I<ithreads>) model. However, some previous functionality is not available.
+Further, the data sharing models between the two thread models are completely
+different, and anything to do with data sharing has to be thought differently.
+With I<ithreads>, you must explicitly C<share()> variables between the
+threads.
+
+You are strongly encouraged to migrate any existing threaded code to the new
+model (i.e., use the C<threads> and C<threads::shared> modules) as soon as
+possible.
+
+=head1 HISTORY
+
+In Perl 5.005, the thread model was that all data is implicitly shared, and
+shared access to data has to be explicitly synchronized. This model is called
+I<5005threads>.
+
+In Perl 5.6, a new model was introduced in which all is was thread local and
+shared access to data has to be explicitly declared. This model is called
+I<ithreads>, for "interpreter threads".
+
+In Perl 5.6, the I<ithreads> model was not available as a public API; only as
+an internal API that was available for extension writers, and to implement
+fork() emulation on Win32 platforms.
+
+In Perl 5.8, the I<ithreads> model became available through the C<threads>
+module, and the I<5005threads> model was deprecated.
+
+In Perl 5.10, the I<5005threads> model was removed from the Perl interpreter.
+
+=head1 SYNOPSIS
+
+ use Thread qw(:DEFAULT async yield);
+
+ my $t = Thread->new(\&start_sub, @start_args);
+
+ $result = $t->join;
+ $t->detach;
+
+ if ($t->done) {
+ $t->join;
+ }
+
+ if($t->equal($another_thread)) {
+ # ...
+ }
+
+ yield();
+
+ my $tid = Thread->self->tid;
+
+ lock($scalar);
+ lock(@array);
+ lock(%hash);
+
+ my @list = Thread->list;
+
+=head1 DESCRIPTION
+
+The C<Thread> module provides multithreading support for Perl.
+
+=head1 FUNCTIONS
+
+=over 8
+
+=item $thread = Thread->new(\&start_sub)
+
+=item $thread = Thread->new(\&start_sub, LIST)
+
+C<new> starts a new thread of execution in the referenced subroutine. The
+optional list is passed as parameters to the subroutine. Execution
+continues in both the subroutine and the code after the C<new> call.
+
+C<Thread-&gt;new> returns a thread object representing the newly created
+thread.
+
+=item lock VARIABLE
+
+C<lock> places a 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. C<lock> is recursive, so multiple calls
+to C<lock> are safe--the variable will remain locked until the
+outermost lock on the variable goes out of scope.
+
+Locks on variables only affect C<lock> calls--they do I<not> affect normal
+access to a variable. (Locks on subs are different, and covered in a bit.)
+If you really, I<really> want locks to block access, then go ahead and tie
+them to something and manage this yourself. This is done on purpose.
+While managing access to variables is a good thing, Perl doesn't force
+you out of its living room...
+
+If a container object, such as a hash or array, is locked, all the
+elements of that container are not locked. For example, if a thread
+does a C<lock @a>, any other thread doing a C<lock($a[12])> won't
+block.
+
+Finally, C<lock> will traverse up references exactly I<one> level.
+C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not.
+
+=item async BLOCK;
+
+C<async> creates a thread to execute the block immediately following
+it. This block is treated as an anonymous sub, and so must have a
+semi-colon after the closing brace. Like C<Thread-&gt;new>, C<async>
+returns a thread object.
+
+=item Thread->self
+
+The C<Thread-E<gt>self> function returns a thread object that represents
+the thread making the C<Thread-E<gt>self> call.
+
+=item Thread->list
+
+Returns a list of all non-joined, non-detached Thread objects.
+
+=item cond_wait VARIABLE
+
+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 reblock waiting
+to reaquire the lock on the variable. (So if you're only using
+C<cond_wait> for synchronization, give up the lock as soon as
+possible.)
+
+=item cond_signal VARIABLE
+
+The C<cond_signal> function takes a 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.
+
+=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.
+
+=item yield
+
+The C<yield> function allows another thread to take control of the
+CPU. The exact results are implementation-dependent.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=item join
+
+C<join> waits for a thread to end and returns any values the thread
+exited with. C<join> will block until the thread has ended, though
+it won't block if the thread has already terminated.
+
+If the thread being C<join>ed C<die>d, the error it died with will
+be returned at this time. If you don't want the thread performing
+the C<join> to die as well, you should either wrap the C<join> in
+an C<eval> or use the C<eval> thread method instead of C<join>.
+
+=item detach
+
+C<detach> tells a thread that it is never going to be joined i.e.
+that all traces of its existence can be removed once it stops running.
+Errors in detached threads will not be visible anywhere - if you want
+to catch them, you should use $SIG{__DIE__} or something like that.
+
+=item equal
+
+C<equal> tests whether two thread objects represent the same thread and
+returns true if they do.
+
+=item tid
+
+The C<tid> method returns the tid of a thread. The tid is
+a monotonically increasing integer assigned when a thread is
+created. The main thread of a program will have a tid of zero,
+while subsequent threads will have tids assigned starting with one.
+
+=item done
+
+The C<done> method returns true if the thread you're checking has
+finished, and false otherwise.
+
+=back
+
+=head1 DEFUNCT
+
+The following were implemented with I<5005threads>, but are no longer
+available with I<ithreads>.
+
+=over 8
+
+=item lock(\&sub)
+
+With 5005threads, you could also C<lock> a sub such that any calls to that sub
+from another thread would block until the lock was released.
+
+Also, subroutines could be declared with the C<:locked> attribute which would
+serialize access to the subroutine, but allowed different threads
+non-simultaneous access.
+
+=item eval
+
+The C<eval> method wrapped an C<eval> around a C<join>, and so waited for a
+thread to exit, passing along any values the thread might have returned and
+placing any errors into C<$@>.
+
+=item flags
+
+The C<flags> method returned the flags for the thread - an integer value
+corresponding to the internal flags for the thread.
+
+=back
+
+=head1 SEE ALSO
+
+L<threads>, L<threads::shared>, L<Thread::Queue>, L<Thread::Semaphore>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk.pm b/Master/tlpkg/tlperl/lib/Tk.pm
new file mode 100644
index 00000000000..494db746d2a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk.pm
@@ -0,0 +1,856 @@
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in Tk/license.terms due to partial
+# derivation from Tk8.0 sources.
+#
+package Tk;
+require 5.007;
+use Tk::Event ();
+use AutoLoader qw(AUTOLOAD);
+use DynaLoader;
+use Cwd();
+use base qw(Exporter DynaLoader);
+use File::Spec qw();
+
+*fileevent = \&Tk::Event::IO::fileevent;
+
+use Encode;
+$Tk::encodeStopOnError = Encode::FB_QUIET();
+$Tk::encodeFallback = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT();
+
+our %font_encoding = ('jis0208' => 'jis0208-raw',
+ 'jis0212' => 'jis0212-raw',
+ 'ksc5601' => 'ksc5601-raw',
+ 'gb2312' => 'gb2312-raw',
+ 'unicode' => 'ucs-2le',
+ );
+
+BEGIN {
+ if($^O eq 'cygwin')
+ {
+ require Tk::Config;
+ $Tk::platform = $Tk::Config::win_arch;
+ $Tk::platform = 'unix' if $Tk::platform eq 'x';
+ }
+ else
+ {
+ $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix';
+ }
+};
+
+$Tk::tearoff = 1 if ($Tk::platform eq 'unix');
+
+
+@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit);
+@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION
+ DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS
+ IDLE_EVENTS ALL_EVENTS
+ NORMAL_BG ACTIVE_BG SELECT_BG
+ SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE);
+%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS
+ TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)],
+ variables => [qw(*widget *event)],
+ colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG
+ TROUGH INDICATOR DISABLED BLACK WHITE)],
+ );
+
+use strict;
+use Carp;
+
+# Record author's perforce depot record
+#$Tk::CHANGE = q$Change: 3279 $;
+$Tk::CHANGE = 'sfsvn-' . q$Change: 27 $;
+
+# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow
+# is created, $VERSION is checked by bootstrap
+$Tk::version = '8.4';
+$Tk::patchLevel = '8.4';
+$Tk::VERSION = '804.029';
+$Tk::VERSION = eval $Tk::VERSION;
+$Tk::XS_VERSION = $Tk::VERSION;
+$Tk::strictMotif = 0;
+
+
+{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;}
+$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library);
+
+$Tk::widget = undef;
+$Tk::event = undef;
+
+use vars qw($inMainLoop);
+
+bootstrap Tk;
+
+my $boot_time = timeofday();
+
+# This is a workround for Solaris X11 locale handling
+Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11'))
+ if (NeedPreload() && -d '/usr/openwin/lib');
+
+use Tk::Submethods ('option' => [qw(add get clear readfile)],
+ 'clipboard' => [qw(clear append get)]
+ );
+
+#
+# Next few routines are here as perl code as doing caller()
+# in XS code is very complicated - so instead C code calls BackTrace
+#
+sub _backTrace
+{
+ my $w = shift;
+ my $i = 1;
+ my ($pack,$file,$line,$sub) = caller($i++);
+ while (1)
+ {
+ my $loc = "at $file line $line";
+ ($pack,$file,$line,$sub) = caller($i++);
+ last unless defined($sub);
+ return 1 if $sub eq '(eval)';
+ $w->AddErrorInfo("$sub $loc");
+ }
+ return 0;
+}
+
+sub BackTrace
+{
+ my $w = shift;
+ return unless (@_ || $@);
+ my $mess = (@_) ? shift : "$@";
+ die "$mess\n" if $w->_backTrace;
+ # if we get here we are not in an eval so report now
+ $w->Fail($mess);
+ $w->idletasks;
+ die "$mess\n";
+}
+
+#
+# This is a $SIG{__DIE__} handler which does not change the $@
+# string in the way 'croak' does, but rather add to Tk's ErrorInfo.
+# It stops at 1st enclosing eval on assumption that the eval
+# is part of Tk call process and will add its own context to ErrorInfo
+# and then pass on the error.
+#
+sub __DIE__
+{
+ my $mess = shift;
+ my $w = $Tk::widget;
+ # Note that if a __DIE__ handler returns it re-dies up the chain.
+ return unless defined($w) && Exists($w);
+ # This special message is for exit() as an exception see pTkCallback.c
+ return if $mess =~/^_TK_EXIT_\(\d+\)/;
+ return if $w->_backTrace;
+ # Not in an eval - should not happen
+}
+
+sub XEvent::xy { shift->Info('xy') }
+
+sub XEvent::AUTOLOAD
+{
+ my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/;
+ no strict 'refs';
+ *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) };
+ goto &$XEvent::AUTOLOAD;
+}
+
+sub NoOp { }
+
+sub Ev
+{
+ if (@_ == 1)
+ {
+ my $arg = $_[0];
+ return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev');
+ }
+ else
+ {
+ return bless [@_],'Tk::Ev';
+ }
+}
+
+sub InitClass
+{
+ my ($package,$parent) = @_;
+ croak "Unexpected type of parent $parent" unless(ref $parent);
+ croak "$parent is not a widget" unless($parent->IsWidget);
+ my $mw = $parent->MainWindow;
+ my $hash = $mw->TkHash('_ClassInit_');
+ unless (exists $hash->{$package})
+ {
+ $package->Install($mw);
+ $hash->{$package} = $package->ClassInit($mw);
+ }
+}
+
+require Tk::Widget;
+require Tk::Image;
+require Tk::MainWindow;
+
+sub Exists
+{my $w = shift;
+ return defined($w) && ref($w) && $w->IsWidget && $w->exists;
+}
+
+sub Time_So_Far
+{
+ return timeofday() - $boot_time;
+}
+
+# Selection* are not autoloaded as names are too long.
+
+sub SelectionOwn
+{my $widget = shift;
+ selection('own',(@_,$widget));
+}
+
+sub SelectionOwner
+{
+ selection('own','-displayof',@_);
+}
+
+sub SelectionClear
+{
+ selection('clear','-displayof',@_);
+}
+
+sub SelectionExists
+{
+ selection('exists','-displayof',@_);
+}
+
+sub SelectionHandle
+{my $widget = shift;
+ my $command = pop;
+ selection('handle',@_,$widget,$command);
+}
+
+sub SplitString
+{
+ local $_ = shift;
+ my (@arr, $tmp);
+ while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
+ if (defined $1) { push @arr, $1 }
+ else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp }
+ }
+ # carp '('.join(',',@arr).")";
+ return @arr;
+}
+
+sub Methods
+{
+ my ($package) = caller;
+ no strict 'refs';
+ foreach my $meth (@_)
+ {
+ my $name = $meth;
+ *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) };
+ }
+}
+
+my %dialog = ( tk_chooseColor => 'ColorDialog',
+ tk_messageBox => 'MessageBox',
+ tk_getOpenFile => 'FDialog',
+ tk_getSaveFile => 'FDialog',
+ tk_chooseDirectory => 'FDialog'
+# Slaven claims NI-S's version above does not work
+# and provides this
+# tk_chooseDirectory => 'DirDialog'
+ );
+
+foreach my $dialog (keys %dialog)
+ {
+ no strict 'refs';
+ unless (defined &$dialog)
+ {
+ my $kind = $dialog;
+ my $code = \&{"Tk::$dialog{$dialog}"};
+ *$dialog = sub { &$code($kind,@_) };
+ }
+ }
+
+sub MessageBox {
+ my ($kind,%args) = @_;
+ require Tk::Dialog;
+ my $parent = delete $args{'-parent'};
+ my $args = \%args;
+
+ $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
+ $args->{-text} = delete $args->{-message} if defined $args->{-message};
+ $args->{-type} = 'OK' unless defined $args->{-type};
+
+ my $type;
+ if (defined($type = delete $args->{-type})) {
+ delete $args->{-type};
+ my @buttons = grep($_,map(ucfirst($_),
+ split(/(abort|retry|ignore|yes|no|cancel|ok)/,
+ lc($type))));
+ $args->{-buttons} = [@buttons];
+ $args->{-default_button} = ucfirst(delete $args->{-default}) if
+ defined $args->{-default};
+ if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
+ $args->{-default_button} = $buttons[0];
+ }
+ my $md = $parent->Dialog(%$args);
+ my $an = $md->Show;
+ $md->destroy if Tk::Exists($md);
+ return $an;
+ }
+} # end messageBox
+
+sub messageBox
+{
+ my ($widget,%args) = @_;
+ # remove in a later version:
+ if (exists $args{'-text'})
+ {
+ warn "The -text option is deprecated. Please use -message instead";
+ if (!exists $args{'-message'})
+ {
+ $args{'-message'} = delete $args{'-text'};
+ }
+ }
+ $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
+ $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'});
+ ucfirst tk_messageBox(-parent => $widget, %args);
+}
+sub _adapt_path_to_os
+{
+ # adapting the path of -initalfile and -initialdir to the operating system
+ # (like that getOpenFile(-initialdir => 'c:/WINNT') will work, as it will
+ # be converted to c:\WINNT)
+ my %args = @_;
+ foreach my $option (qw(-initialfile -initialdir))
+ {
+ if ($args{$option})
+ {
+ $args{$option} = File::Spec->catfile($args{$option});
+ }
+ }
+ return %args;
+}
+sub getOpenFile
+{
+ tk_getOpenFile(-parent => shift,_adapt_path_to_os(@_));
+}
+
+sub getSaveFile
+{
+ tk_getSaveFile(-parent => shift,_adapt_path_to_os(@_));
+}
+
+sub chooseColor
+{
+ tk_chooseColor(-parent => shift,@_);
+}
+
+sub chooseDirectory
+{
+ tk_chooseDirectory(-parent => shift,_adapt_path_to_os(@_));
+}
+
+sub DialogWrapper
+{
+ my ($method,$kind,%args) = @_;
+ my $created = 0;
+ my $w = delete $args{'-parent'};
+ if (defined $w)
+ {
+ $args{'-popover'} = $w;
+ }
+ else
+ {
+ $w = MainWindow->new;
+ $w->withdraw;
+ $created = 1;
+ }
+ my $mw = $w->toplevel;
+ my $fs = $mw->{$kind};
+ unless (defined $fs)
+ {
+ $mw->{$kind} = $fs = $mw->$method(%args);
+ }
+ else
+ {
+ $fs->configure(%args);
+ }
+ my $val = $fs->Show;
+ $w->destroy if $created;
+ return $val;
+}
+
+sub ColorDialog
+{
+ require Tk::ColorEditor;
+ DialogWrapper('ColorDialog',@_);
+}
+
+sub FDialog
+{
+ require Tk::FBox;
+ my $cmd = shift;
+ if ($cmd =~ /Save/)
+ {
+ push @_, -type => 'save';
+ }
+ elsif ($cmd =~ /Directory/)
+ {
+ push @_, -type => 'dir';
+ }
+ DialogWrapper('FBox', $cmd, @_);
+}
+
+sub DirDialog
+{
+ require Tk::DirTree;
+ DialogWrapper('DirTreeDialog',@_);
+}
+
+*MotifFDialog = \&FDialog;
+
+*CORE::GLOBAL::exit = \&exit;
+
+sub MainLoop
+{
+ unless ($inMainLoop)
+ {
+ local $inMainLoop = 1;
+ while (Tk::MainWindow->Count)
+ {
+ DoOneEvent(0);
+ }
+ }
+}
+
+sub tkinit { return MainWindow->new(@_) }
+
+# a wrapper on eval which turns off user $SIG{__DIE__}
+sub catch (&)
+{
+ my $sub = shift;
+ eval {local $SIG{'__DIE__'}; &$sub };
+}
+
+my $Home;
+
+sub TranslateFileName
+{
+ local $_ = shift;
+ unless (defined $Home)
+ {
+ $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : "");
+ $Home =~ s#\\#/#g;
+ $Home .= '/' unless $Home =~ m#/$#;
+ }
+ s#~/#$Home#g;
+ # warn $_;
+ return $_;
+}
+
+sub findINC
+{
+ my $file = join('/',@_);
+ my $dir;
+ $file =~ s,::,/,g;
+ foreach $dir (@INC)
+ {
+ my $path;
+ return $path if (-e ($path = "$dir/$file"));
+ }
+ return undef;
+}
+
+sub idletasks
+{
+ shift->update('idletasks');
+}
+
+sub backtrace
+{
+ my ($self,$msg,$i) = @_;
+ $i = 1 if @_ < 3;
+ while (1)
+ {
+ my ($pack,$file,$line,$sub) = caller($i++);
+ last unless defined($sub);
+ $msg .= "\n $sub at $file line $line";
+ }
+ return "$msg\n";
+}
+
+sub die_with_trace
+{
+ my ($self,$msg) = @_;
+ die $self->backtrace($msg,1);
+}
+
+
+
+1;
+
+__END__
+
+sub Error
+{my $w = shift;
+ my $error = shift;
+ if (Exists($w))
+ {
+ my $grab = $w->grab('current');
+ $grab->Unbusy if (defined $grab);
+ }
+ chomp($error);
+ warn "Tk::Error: $error\n " . join("\n ",@_)."\n";
+}
+
+sub CancelRepeat
+{
+ my $w = shift->MainWindow;
+ my $id = delete $w->{_afterId_};
+ $w->after('cancel',$id) if (defined $id);
+}
+
+sub RepeatId
+{
+ my ($w,$id) = @_;
+ $w = $w->MainWindow;
+ $w->CancelRepeat;
+ $w->{_afterId_} = $id;
+}
+
+
+
+#----------------------------------------------------------------------------
+# focus.tcl --
+#
+# This file defines several procedures for managing the input
+# focus.
+#
+# @(#) focus.tcl 1.6 94/12/19 17:06:46
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+sub FocusChildren { shift->children }
+
+#
+# focusNext --
+# This procedure is invoked to move the input focus to the next window
+# after a given one. "Next" is defined in terms of the window
+# stacking order, with all the windows underneath a given top-level
+# (no matter how deeply nested in the hierarchy) considered except
+# for frames and toplevels.
+#
+# Arguments:
+# w - Name of a window: the procedure will set the focus
+# to the next window after this one in the traversal
+# order.
+sub focusNext
+{
+ my $w = shift;
+ my $cur = $w->getNextFocus;
+ if ($cur)
+ {
+ $cur->tabFocus;
+ }
+}
+
+sub getNextFocus
+{
+ my $w = shift;
+ my $cur = $w;
+ while (1)
+ {
+ # Descend to just before the first child of the current widget.
+ my $parent = $cur;
+ my @children = $cur->FocusChildren();
+ my $i = -1;
+ # Look for the next sibling that isn't a top-level.
+ while (1)
+ {
+ $i += 1;
+ if ($i < @children)
+ {
+ $cur = $children[$i];
+ next if ($cur->toplevel == $cur);
+ last
+ }
+ # No more siblings, so go to the current widget's parent.
+ # If it's a top-level, break out of the loop, otherwise
+ # look for its next sibling.
+ $cur = $parent;
+ last if ($cur->toplevel() == $cur);
+ $parent = $parent->parent();
+ @children = $parent->FocusChildren();
+ $i = lsearch(\@children,$cur);
+ }
+ if ($cur == $w || $cur->FocusOK)
+ {
+ return $cur;
+ }
+ }
+}
+# focusPrev --
+# This procedure is invoked to move the input focus to the previous
+# window before a given one. "Previous" is defined in terms of the
+# window stacking order, with all the windows underneath a given
+# top-level (no matter how deeply nested in the hierarchy) considered.
+#
+# Arguments:
+# w - Name of a window: the procedure will set the focus
+# to the previous window before this one in the traversal
+# order.
+sub focusPrev
+{
+ my $w = shift;
+ my $cur = $w->getPrevFocus;
+ if ($cur)
+ {
+ $cur->tabFocus;
+ }
+}
+
+sub getPrevFocus
+{
+ my $w = shift;
+ my $cur = $w;
+ my @children;
+ my $i;
+ my $parent;
+ while (1)
+ {
+ # Collect information about the current window's position
+ # among its siblings. Also, if the window is a top-level,
+ # then reposition to just after the last child of the window.
+ if ($cur->toplevel() == $cur)
+ {
+ $parent = $cur;
+ @children = $cur->FocusChildren();
+ $i = @children;
+ }
+ else
+ {
+ $parent = $cur->parent();
+ @children = $parent->FocusChildren();
+ $i = lsearch(\@children,$cur);
+ }
+ # Go to the previous sibling, then descend to its last descendant
+ # (highest in stacking order. While doing this, ignore top-levels
+ # and their descendants. When we run out of descendants, go up
+ # one level to the parent.
+ while ($i > 0)
+ {
+ $i--;
+ $cur = $children[$i];
+ next if ($cur->toplevel() == $cur);
+ $parent = $cur;
+ @children = $parent->FocusChildren();
+ $i = @children;
+ }
+ $cur = $parent;
+ if ($cur == $w || $cur->FocusOK)
+ {
+ return $cur;
+ }
+ }
+
+}
+
+sub FocusOK
+{
+ my $w = shift;
+ my $value;
+ catch { $value = $w->cget('-takefocus') };
+ if (!$@ && defined($value))
+ {
+ return 0 if ($value eq '0');
+ return $w->viewable if ($value eq '1');
+ if ($value)
+ {
+ $value = $w->$value();
+ return $value if (defined $value);
+ }
+ }
+ if (!$w->viewable)
+ {
+ return 0;
+ }
+ catch { $value = $w->cget('-state') } ;
+ if (!$@ && defined($value) && $value eq 'disabled')
+ {
+ return 0;
+ }
+ $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w)));
+ return $value;
+}
+
+
+# focusFollowsMouse
+#
+# If this procedure is invoked, Tk will enter "focus-follows-mouse"
+# mode, where the focus is always on whatever window contains the
+# mouse. If this procedure isn't invoked, then the user typically
+# has to click on a window to give it the focus.
+#
+# Arguments:
+# None.
+
+sub EnterFocus
+{
+ my $w = shift;
+ return unless $w;
+ my $Ev = $w->XEvent;
+ my $d = $Ev->d;
+ $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior');
+}
+
+sub tabFocus
+{
+ shift->Tk::focus;
+}
+
+sub focusFollowsMouse
+{
+ my $widget = shift;
+ $widget->bind('all','<Enter>','EnterFocus');
+}
+
+# tkTraverseToMenu --
+# This procedure implements keyboard traversal of menus. Given an
+# ASCII character "char", it looks for a menubutton with that character
+# underlined. If one is found, it posts the menubutton's menu
+#
+# Arguments:
+# w - Window in which the key was typed (selects
+# a toplevel window).
+# char - Character that selects a menu. The case
+# is ignored. If an empty string, nothing
+# happens.
+sub TraverseToMenu
+{
+ my $w = shift;
+ my $char = shift;
+ return unless(defined $char && $char ne '');
+ $w = $w->toplevel->FindMenu($char);
+}
+# tkFirstMenu --
+# This procedure traverses to the first menubutton in the toplevel
+# for a given window, and posts that menubutton's menu.
+#
+# Arguments:
+# w - Name of a window. Selects which toplevel
+# to search for menubuttons.
+sub FirstMenu
+{
+ my $w = shift;
+ $w = $w->toplevel->FindMenu('');
+}
+
+# These wrappers don't use method syntax so need to live
+# in same package as raw Tk routines are newXS'ed into.
+
+sub Selection
+{my $widget = shift;
+ my $cmd = shift;
+ croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own');
+ croak "Use Selection\u$cmd()";
+}
+
+# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....)
+# calls it when it does its eval "require $base"
+#sub Clipboard
+#{my $w = shift;
+# my $cmd = shift;
+# croak "Use clipboard\u$cmd()";
+#}
+
+sub Receive
+{
+ my $w = shift;
+ warn 'Receive(' . join(',',@_) .')';
+ die 'Tk rejects send(' . join(',',@_) .")\n";
+}
+
+sub break
+{
+ die "_TK_BREAK_\n";
+}
+
+sub updateWidgets
+{
+ my ($w) = @_;
+ while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS))
+ {
+ }
+ $w;
+}
+
+sub ImageNames
+{
+ image('names');
+}
+
+sub ImageTypes
+{
+ image('types');
+}
+
+sub interps
+{
+ my $w = shift;
+ return $w->winfo('interps','-displayof');
+}
+
+sub lsearch
+{my $ar = shift;
+ my $x = shift;
+ my $i;
+ for ($i = 0; $i < scalar @$ar; $i++)
+ {
+ return $i if ($$ar[$i] eq $x);
+ }
+ return -1;
+}
+
+
+sub getEncoding
+{
+ my ($class,$name) = @_;
+ eval { require Encode };
+ if ($@)
+ {
+ require Tk::DummyEncode;
+ return Tk::DummyEncode->getEncoding($name);
+ }
+ $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
+ my $enc = Encode::find_encoding($name);
+
+ unless ($enc)
+ {
+ $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
+ }
+# if ($enc)
+# {
+# print STDERR "Lookup '$name' => ".$enc->name."\n";
+# }
+# else
+# {
+# print STDERR "Failed '$name'\n";
+# }
+ unless ($enc)
+ {
+ if ($name eq 'X11ControlChars')
+ {
+ require Tk::DummyEncode;
+ $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
+ }
+ }
+ return $enc;
+}
+
+
+
diff --git a/Master/tlpkg/tlperl/lib/Tk.pod b/Master/tlpkg/tlperl/lib/Tk.pod
new file mode 100644
index 00000000000..1024b3b4c5b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk.pod
@@ -0,0 +1,862 @@
+=head1 NAME
+
+Tk - a graphical user interface toolkit for Perl
+
+=head1 SYNOPSIS
+
+ use Tk;
+ $top = new MainWindow;
+ MainLoop;
+
+=head1 DESCRIPTION
+
+The Perl/Tk manual is split up into a number of sections:
+
+=head2 Introduction
+
+=over 4
+
+=item *
+
+L<Tk::overview|Tk::overview>
+
+=item *
+
+L<Tk::UserGuide|Tk::UserGuide>
+
+=back
+
+=head2 Tk Geometry Management
+
+=over 4
+
+=item *
+
+L<Tk::Adjuster|Tk::Adjuster>
+
+=item *
+
+L<Tk::form|Tk::form>
+
+=item *
+
+L<Tk::grid|Tk::grid>
+
+=item *
+
+L<Tk::pack|Tk::pack>
+
+=item *
+
+L<Tk::place|Tk::place>
+
+=item *
+
+L<Tk::Table|Tk::Table>
+
+=item *
+
+L<Tk::Tiler|Tk::Tiler>
+
+=item *
+
+L<Tk::Wm|Tk::Wm>
+
+=back
+
+=head2 Binding Events and Callbacks
+
+=over 4
+
+=item *
+
+L<Tk::after|Tk::after>
+
+=item *
+
+L<Tk::bind|Tk::bind>
+
+=item *
+
+L<Tk::bindtags|Tk::bindtags>
+
+=item *
+
+L<Tk::callbacks|Tk::callbacks>
+
+=item *
+
+L<Tk::Error|Tk::Error>
+
+=item *
+
+L<Tk::event|Tk::event>
+
+=item *
+
+L<Tk::exit|Tk::exit>
+
+=item *
+
+L<Tk::fileevent|Tk::fileevent>
+
+=item *
+
+L<Tk::IO|Tk::IO>
+
+=back
+
+=head2 Tk Image Classes
+
+=over 4
+
+=item *
+
+L<Tk::Animation|Tk::Animation>
+
+=item *
+
+L<Tk::Bitmap|Tk::Bitmap>
+
+=item *
+
+L<Tk::Compound|Tk::Compound>
+
+=item *
+
+L<Tk::Image|Tk::Image>
+
+=item *
+
+L<Tk::JPEG|Tk::JPEG>
+
+=item *
+
+L<Tk::Photo|Tk::Photo>
+
+=item *
+
+L<Tk::Pixmap|Tk::Pixmap>
+
+=item *
+
+L<Tk::PNG|Tk::PNG>
+
+=back
+
+=head2 Tk Widget Classes
+
+=over 4
+
+=item *
+
+L<Tk::Button|Tk::Button>
+
+=item *
+
+L<Tk::Canvas|Tk::Canvas>
+
+=item *
+
+L<Tk::Checkbutton|Tk::Checkbutton>
+
+=item *
+
+L<Tk::Entry|Tk::Entry>
+
+=item *
+
+L<Tk::Frame|Tk::Frame>
+
+=item *
+
+L<Tk::HList|Tk::HList>
+
+=item *
+
+L<Tk::Label|Tk::Label>
+
+=item *
+
+L<Tk::Listbox|Tk::Listbox>
+
+=item *
+
+L<Tk::Menu|Tk::Menu>
+
+=item *
+
+L<Tk::Menubutton|Tk::Menubutton>
+
+=item *
+
+L<Tk::Message|Tk::Message>
+
+=item *
+
+L<Tk::Optionmenu|Tk::Optionmenu>
+
+=item *
+
+L<Tk::Radiobutton|Tk::Radiobutton>
+
+=item *
+
+L<Tk::Scale|Tk::Scale>
+
+=item *
+
+L<Tk::Scrollbar|Tk::Scrollbar>
+
+=item *
+
+L<Tk::Text|Tk::Text>
+
+=item *
+
+L<Tk::Toplevel|Tk::Toplevel>
+
+=back
+
+=head2 Tix Extensions
+
+=over 4
+
+=item *
+
+L<Tk::Balloon|Tk::Balloon>
+
+=item *
+
+L<Tk::BrowseEntry|Tk::BrowseEntry>
+
+=item *
+
+L<Tk::DialogBox|Tk::DialogBox>
+
+=item *
+
+L<Tk::DirTree|Tk::DirTree>
+
+=item *
+
+L<Tk::DItem|Tk::DItem>
+
+=item *
+
+L<Tk::InputO|Tk::InputO>
+
+=item *
+
+L<Tk::LabFrame|Tk::LabFrame>
+
+=item *
+
+L<Tk::Mwm|Tk::Mwm>
+
+=item *
+
+L<Tk::NoteBook|Tk::NoteBook>
+
+=item *
+
+L<Tk::TixGrid|Tk::TixGrid>
+
+=item *
+
+L<Tk::tixWm|Tk::tixWm>
+
+=item *
+
+L<Tk::TList|Tk::TList>
+
+=item *
+
+L<Tk::Tree|Tk::Tree>
+
+=back
+
+=head2 Tk Generic Methods
+
+=over 4
+
+=item *
+
+L<Tk::Font|Tk::Font>
+
+=item *
+
+L<Tk::send|Tk::send>
+
+=item *
+
+L<Tk::tkvars|Tk::tkvars>
+
+=item *
+
+L<Tk::Widget|Tk::Widget>
+
+=item *
+
+L<Tk::X11Font|Tk::X11Font>
+
+=back
+
+=head2 User Interaction
+
+=over 4
+
+=item *
+
+L<Tk::DropSite|Tk::DropSite>
+
+=item *
+
+L<Tk::Clipboard|Tk::Clipboard>
+
+=item *
+
+L<Tk::focus|Tk::focus>
+
+=item *
+
+L<Tk::grab|Tk::grab>
+
+=item *
+
+L<Tk::selection|Tk::selection>
+
+=back
+
+=head2 Creating and Configuring Widgets
+
+=over 4
+
+=item *
+
+L<Tk::CmdLine|Tk::CmdLine>
+
+=item *
+
+L<Tk::MainWindow|Tk::MainWindow>
+
+=item *
+
+L<Tk::option|Tk::option>
+
+=item *
+
+L<Tk::options|Tk::options>
+
+=item *
+
+L<Tk::palette|Tk::palette>
+
+=item *
+
+L<Tk::Xrm|Tk::Xrm>
+
+=back
+
+=head2 Popups and Dialogs
+
+=over 4
+
+=item *
+
+L<Tk::chooseColor|Tk::chooseColor>
+
+=item *
+
+L<Tk::chooseDirectory|Tk::chooseDirectory>
+
+=item *
+
+L<Tk::ColorEditor|Tk::ColorEditor>
+
+=item *
+
+L<Tk::Dialog|Tk::Dialog>
+
+=item *
+
+L<Tk::DialogBox|Tk::DialogBox>
+
+=item *
+
+L<Tk::FBox|Tk::FBox>
+
+=item *
+
+L<Tk::FileSelect|Tk::FileSelect>
+
+=item *
+
+L<Tk::getOpenFile|Tk::getOpenFile>
+
+=item *
+
+L<Tk::messageBox|Tk::messageBox>
+
+=item *
+
+L<Tk::MsgBox|Tk::MsgBox>
+
+=back
+
+=head2 Derived Widgets
+
+=over 4
+
+=item *
+
+L<Tk::composite|Tk::composite>
+
+=item *
+
+L<Tk::configspec|Tk::configspec>
+
+=item *
+
+L<Tk::Derived|Tk::Derived>
+
+=item *
+
+L<Tk::mega|Tk::mega>
+
+=item *
+
+L<Tk::ROText|Tk::ROText>
+
+=item *
+
+L<Tk::Scrolled|Tk::Scrolled>
+
+=item *
+
+L<Tk::TextUndo|Tk::TextUndo>
+
+=item *
+
+L<Tk::Reindex|Tk::Reindex>
+
+=item *
+
+L<Tk::Pane|Tk::Pane>
+
+=item *
+
+L<Tk::ProgressBar|Tk::ProgressBar>
+
+=back
+
+=head2 C Programming
+
+=over 4
+
+=item *
+
+Internals
+
+=item *
+
+pTk
+
+=item *
+
+3DBorder
+
+=item *
+
+BackgdErr
+
+=item *
+
+BindTable
+
+=item *
+
+CanvPsY
+
+=item *
+
+CanvTkwin
+
+=item *
+
+CanvTxtInfo
+
+=item *
+
+Clipboard
+
+=item *
+
+ClrSelect
+
+=item *
+
+ConfigWidg
+
+=item *
+
+ConfigWind
+
+=item *
+
+CoordToWin
+
+=item *
+
+CrtErrHdlr
+
+=item *
+
+CrtGenHdlr
+
+=item *
+
+CrtImgType
+
+=item *
+
+CrtItemType
+
+=item *
+
+CrtMainWin
+
+=item *
+
+CrtPhImgFmt
+
+=item *
+
+CrtSelHdlr
+
+=item *
+
+CrtWindow
+
+=item *
+
+DeleteImg
+
+=item *
+
+DoOneEvent
+
+=item *
+
+DoWhenIdle
+
+=item *
+
+DrawFocHlt
+
+=item *
+
+EventHndlr
+
+=item *
+
+EventInit
+
+=item *
+
+FileHndlr
+
+=item *
+
+FindPhoto
+
+=item *
+
+FontId
+
+=item *
+
+FreeXId
+
+=item *
+
+GeomReq
+
+=item *
+
+GetAnchor
+
+=item *
+
+GetBitmap
+
+=item *
+
+GetCapStyl
+
+=item *
+
+GetClrmap
+
+=item *
+
+GetColor
+
+=item *
+
+GetCursor
+
+=item *
+
+GetFont
+
+=item *
+
+GetFontStr
+
+=item *
+
+GetGC
+
+=item *
+
+GetImage
+
+=item *
+
+GetJoinStl
+
+=item *
+
+GetJustify
+
+=item *
+
+GetOption
+
+=item *
+
+GetPixels
+
+=item *
+
+GetPixmap
+
+=item *
+
+GetRelief
+
+=item *
+
+GetRootCrd
+
+=item *
+
+GetScroll
+
+=item *
+
+GetSelect
+
+=item *
+
+GetUid
+
+=item *
+
+GetVisual
+
+=item *
+
+GetVRoot
+
+=item *
+
+HandleEvent
+
+=item *
+
+IdToWindow
+
+=item *
+
+ImgChanged
+
+=item *
+
+InternAtom
+
+=item *
+
+MainLoop
+
+=item *
+
+MaintGeom
+
+=item *
+
+MainWin
+
+=item *
+
+ManageGeom
+
+=item *
+
+MapWindow
+
+=item *
+
+MeasureChar
+
+=item *
+
+MoveToplev
+
+=item *
+
+Name
+
+=item *
+
+NameOfImg
+
+=item *
+
+OwnSelect
+
+=item *
+
+ParseArgv
+
+=item *
+
+Preserve
+
+=item *
+
+QWinEvent
+
+=item *
+
+Restack
+
+=item *
+
+RestrictEv
+
+=item *
+
+SetAppName
+
+=item *
+
+SetClass
+
+=item *
+
+SetGrid
+
+=item *
+
+SetVisual
+
+=item *
+
+Sleep
+
+=item *
+
+StrictMotif
+
+=item *
+
+TextLayout
+
+=item *
+
+TimerHndlr
+
+=item *
+
+Tk_Init
+
+=item *
+
+WindowId
+
+=back
+
+=head2 Implementation
+
+=over 4
+
+=item *
+
+L<Tk::Eventloop|Tk::Eventloop>
+
+=item *
+
+L<Tk::Menu::Item|Tk::Menu::Item>
+
+=item *
+
+L<Tk::Submethods|Tk::Submethods>
+
+=item *
+
+L<Tk::WidgetDemo|Tk::WidgetDemo>
+
+=item *
+
+L<Tk::widgets|Tk::widgets>
+
+=back
+
+=head2 Experimental Modules
+
+=over 4
+
+=item *
+
+L<Tk::Common|Tk::Common>
+
+=item *
+
+L<Tk::SunConst|Tk::SunConst>
+
+=item *
+
+L<Tk::WinPhoto|Tk::WinPhoto>
+
+=back
+
+=head2 Other Modules and Languages
+
+=over 4
+
+=item *
+
+Tk::Compile
+
+=item *
+
+L<Tk::Tcl-perl|Tk::Tcl-perl>
+
+=item *
+
+L<Tk::X|Tk::X>
+
+=back
+
+
+=head1 AUTHOR
+
+Nick Ing-Simmons
+
+=head1 SEE ALSO
+
+L<perl>, L<wish(1)>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/UNIVERSAL.pm b/Master/tlpkg/tlperl/lib/UNIVERSAL.pm
new file mode 100644
index 00000000000..e30f5a7eda0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/UNIVERSAL.pm
@@ -0,0 +1,214 @@
+package UNIVERSAL;
+
+our $VERSION = '1.06';
+
+# UNIVERSAL should not contain any extra subs/methods beyond those
+# that it exists to define. The use of Exporter below is a historical
+# accident that can't be fixed without breaking code. Note that we
+# *don't* set @ISA here, as we don't want all classes/objects inheriting from
+# Exporter. It's bad enough that all classes have a import() method
+# whenever UNIVERSAL.pm is loaded.
+require Exporter;
+@EXPORT_OK = qw(isa can VERSION);
+
+# Make sure that even though the import method is called, it doesn't do
+# anything unless called on UNIVERSAL.
+sub import {
+ return unless $_[0] eq __PACKAGE__;
+ return unless @_ > 1;
+ require warnings;
+ warnings::warnif(
+ 'deprecated',
+ 'UNIVERSAL->import is deprecated and will be removed in a future perl',
+ );
+ goto &Exporter::import;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+UNIVERSAL - base class for ALL classes (blessed references)
+
+=head1 SYNOPSIS
+
+ $is_io = $fd->isa("IO::Handle");
+ $is_io = Class->isa("IO::Handle");
+
+ $does_log = $obj->DOES("Logger");
+ $does_log = Class->DOES("Logger");
+
+ $sub = $obj->can("print");
+ $sub = Class->can("print");
+
+ $sub = eval { $ref->can("fandango") };
+ $ver = $obj->VERSION;
+
+ # but never do this!
+ $is_io = UNIVERSAL::isa($fd, "IO::Handle");
+ $sub = UNIVERSAL::can($obj, "print");
+
+=head1 DESCRIPTION
+
+C<UNIVERSAL> is the base class from which all blessed references inherit.
+See L<perlobj>.
+
+C<UNIVERSAL> provides the following methods:
+
+=over 4
+
+=item C<< $obj->isa( TYPE ) >>
+
+=item C<< CLASS->isa( TYPE ) >>
+
+=item C<< eval { VAL->isa( TYPE ) } >>
+
+Where
+
+=over 4
+
+=item C<TYPE>
+
+is a package name
+
+=item C<$obj>
+
+is a blessed reference or a package name
+
+=item C<CLASS>
+
+is a package name
+
+=item C<VAL>
+
+is any of the above or an unblessed reference
+
+=back
+
+When used as an instance or class method (C<< $obj->isa( TYPE ) >>),
+C<isa> returns I<true> if $obj is blessed into package C<TYPE> or
+inherits from package C<TYPE>.
+
+When used as a class method (C<< CLASS->isa( TYPE ) >>, sometimes
+referred to as a static method), C<isa> returns I<true> if C<CLASS>
+inherits from (or is itself) the name of the package C<TYPE> or
+inherits from package C<TYPE>.
+
+If you're not sure what you have (the C<VAL> case), wrap the method call in an
+C<eval> block to catch the exception if C<VAL> is undefined.
+
+If you want to be sure that you're calling C<isa> as a method, not a class,
+check the invocant with C<blessed> from L<Scalar::Util> first:
+
+ use Scalar::Util 'blessed';
+
+ if ( blessed( $obj ) && $obj->isa("Some::Class") {
+ ...
+ }
+
+=item C<< $obj->DOES( ROLE ) >>
+
+=item C<< CLASS->DOES( ROLE ) >>
+
+C<DOES> checks if the object or class performs the role C<ROLE>. A role is a
+named group of specific behavior (often methods of particular names and
+signatures), similar to a class, but not necessarily a complete class by
+itself. For example, logging or serialization may be roles.
+
+C<DOES> and C<isa> are similar, in that if either is true, you know that the
+object or class on which you call the method can perform specific behavior.
+However, C<DOES> is different from C<isa> in that it does not care I<how> the
+invocant performs the operations, merely that it does. (C<isa> of course
+mandates an inheritance relationship. Other relationships include aggregation,
+delegation, and mocking.)
+
+By default, classes in Perl only perform the C<UNIVERSAL> role, as well as the
+role of all classes in their inheritance. In other words, by default C<DOES>
+responds identically to C<isa>.
+
+There is a relationship between roles and classes, as each class implies the
+existence of a role of the same name. There is also a relationship between
+inheritance and roles, in that a subclass that inherits from an ancestor class
+implicitly performs any roles its parent performs. Thus you can use C<DOES> in
+place of C<isa> safely, as it will return true in all places where C<isa> will
+return true (provided that any overridden C<DOES> I<and> C<isa> methods behave
+appropriately).
+
+=item C<< $obj->can( METHOD ) >>
+
+=item C<< CLASS->can( METHOD ) >>
+
+=item C<< eval { VAL->can( METHOD ) } >>
+
+C<can> checks if the object or class has a method called C<METHOD>. If it does,
+then it returns a reference to the sub. If it does not, then it returns
+I<undef>. This includes methods inherited or imported by C<$obj>, C<CLASS>, or
+C<VAL>.
+
+C<can> cannot know whether an object will be able to provide a method through
+AUTOLOAD (unless the object's class has overridden C<can> appropriately), so a
+return value of I<undef> does not necessarily mean the object will not be able
+to handle the method call. To get around this some module authors use a forward
+declaration (see L<perlsub>) for methods they will handle via AUTOLOAD. For
+such 'dummy' subs, C<can> will still return a code reference, which, when
+called, will fall through to the AUTOLOAD. If no suitable AUTOLOAD is provided,
+calling the coderef will cause an error.
+
+You may call C<can> as a class (static) method or an object method.
+
+Again, the same rule about having a valid invocant applies -- use an C<eval>
+block or C<blessed> if you need to be extra paranoid.
+
+=item C<VERSION ( [ REQUIRE ] )>
+
+C<VERSION> will return the value of the variable C<$VERSION> in the
+package the object is blessed into. If C<REQUIRE> is given then
+it will do a comparison and die if the package version is not
+greater than or equal to C<REQUIRE>. Both C<$VERSION> or C<REQUIRE>
+must be "lax" version numbers (as defined by the L<version> module)
+or C<VERSION> will die with an error.
+
+C<VERSION> can be called as either a class (static) method or an object
+method.
+
+=back
+
+=head1 WARNINGS
+
+B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and
+C<isa> uses a very similar method and cache-ing strategy. This may cause
+strange effects if the Perl code dynamically changes @ISA in any package.
+
+You may add other methods to the UNIVERSAL class via Perl or XS code.
+You do not need to C<use UNIVERSAL> to make these methods
+available to your program (and you should not do so).
+
+=head1 EXPORTS
+
+None by default.
+
+You may request the import of three functions (C<isa>, C<can>, and C<VERSION>),
+B<but this feature is deprecated and will be removed>. Please don't do this in
+new code.
+
+For example, previous versions of this documentation suggested using C<isa> as
+a function to determine the type of a reference:
+
+ use UNIVERSAL 'isa';
+
+ $yes = isa $h, "HASH";
+ $yes = isa "Foo", "Bar";
+
+The problem is that this code will I<never> call an overridden C<isa> method in
+any class. Instead, use C<reftype> from L<Scalar::Util> for the first case:
+
+ use Scalar::Util 'reftype';
+
+ $yes = reftype( $h ) eq "HASH";
+
+and the method form of C<isa> for the second:
+
+ $yes = Foo->isa("Bar");
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32.pm b/Master/tlpkg/tlperl/lib/Win32.pm
new file mode 100644
index 00000000000..4015eac841c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32.pm
@@ -0,0 +1,793 @@
+package Win32;
+
+BEGIN {
+ use strict;
+ use vars qw|$VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK|;
+
+ require Exporter;
+ require DynaLoader;
+
+ @ISA = qw|Exporter DynaLoader|;
+ $VERSION = '0.39';
+ $XS_VERSION = $VERSION;
+ $VERSION = eval $VERSION;
+
+ @EXPORT = qw(
+ NULL
+ WIN31_CLASS
+ OWNER_SECURITY_INFORMATION
+ GROUP_SECURITY_INFORMATION
+ DACL_SECURITY_INFORMATION
+ SACL_SECURITY_INFORMATION
+ MB_ICONHAND
+ MB_ICONQUESTION
+ MB_ICONEXCLAMATION
+ MB_ICONASTERISK
+ MB_ICONWARNING
+ MB_ICONERROR
+ MB_ICONINFORMATION
+ MB_ICONSTOP
+ );
+ @EXPORT_OK = qw(
+ GetOSName
+ SW_HIDE
+ SW_SHOWNORMAL
+ SW_SHOWMINIMIZED
+ SW_SHOWMAXIMIZED
+ SW_SHOWNOACTIVATE
+
+ CSIDL_DESKTOP
+ CSIDL_PROGRAMS
+ CSIDL_PERSONAL
+ CSIDL_FAVORITES
+ CSIDL_STARTUP
+ CSIDL_RECENT
+ CSIDL_SENDTO
+ CSIDL_STARTMENU
+ CSIDL_MYMUSIC
+ CSIDL_MYVIDEO
+ CSIDL_DESKTOPDIRECTORY
+ CSIDL_NETHOOD
+ CSIDL_FONTS
+ CSIDL_TEMPLATES
+ CSIDL_COMMON_STARTMENU
+ CSIDL_COMMON_PROGRAMS
+ CSIDL_COMMON_STARTUP
+ CSIDL_COMMON_DESKTOPDIRECTORY
+ CSIDL_APPDATA
+ CSIDL_PRINTHOOD
+ CSIDL_LOCAL_APPDATA
+ CSIDL_COMMON_FAVORITES
+ CSIDL_INTERNET_CACHE
+ CSIDL_COOKIES
+ CSIDL_HISTORY
+ CSIDL_COMMON_APPDATA
+ CSIDL_WINDOWS
+ CSIDL_SYSTEM
+ CSIDL_PROGRAM_FILES
+ CSIDL_MYPICTURES
+ CSIDL_PROFILE
+ CSIDL_PROGRAM_FILES_COMMON
+ CSIDL_COMMON_TEMPLATES
+ CSIDL_COMMON_DOCUMENTS
+ CSIDL_COMMON_ADMINTOOLS
+ CSIDL_ADMINTOOLS
+ CSIDL_COMMON_MUSIC
+ CSIDL_COMMON_PICTURES
+ CSIDL_COMMON_VIDEO
+ CSIDL_RESOURCES
+ CSIDL_RESOURCES_LOCALIZED
+ CSIDL_CDBURN_AREA
+ );
+}
+
+# We won't bother with the constant stuff, too much of a hassle. Just hard
+# code it here.
+
+sub NULL { 0 }
+sub WIN31_CLASS { &NULL }
+
+sub OWNER_SECURITY_INFORMATION { 0x00000001 }
+sub GROUP_SECURITY_INFORMATION { 0x00000002 }
+sub DACL_SECURITY_INFORMATION { 0x00000004 }
+sub SACL_SECURITY_INFORMATION { 0x00000008 }
+
+sub MB_ICONHAND { 0x00000010 }
+sub MB_ICONQUESTION { 0x00000020 }
+sub MB_ICONEXCLAMATION { 0x00000030 }
+sub MB_ICONASTERISK { 0x00000040 }
+sub MB_ICONWARNING { 0x00000030 }
+sub MB_ICONERROR { 0x00000010 }
+sub MB_ICONINFORMATION { 0x00000040 }
+sub MB_ICONSTOP { 0x00000010 }
+
+#
+# Newly added constants. These have an empty prototype, unlike the
+# the ones above, which aren't prototyped for compatibility reasons.
+#
+sub SW_HIDE () { 0 }
+sub SW_SHOWNORMAL () { 1 }
+sub SW_SHOWMINIMIZED () { 2 }
+sub SW_SHOWMAXIMIZED () { 3 }
+sub SW_SHOWNOACTIVATE () { 4 }
+
+sub CSIDL_DESKTOP () { 0x0000 } # <desktop>
+sub CSIDL_PROGRAMS () { 0x0002 } # Start Menu\Programs
+sub CSIDL_PERSONAL () { 0x0005 } # "My Documents" folder
+sub CSIDL_FAVORITES () { 0x0006 } # <user name>\Favorites
+sub CSIDL_STARTUP () { 0x0007 } # Start Menu\Programs\Startup
+sub CSIDL_RECENT () { 0x0008 } # <user name>\Recent
+sub CSIDL_SENDTO () { 0x0009 } # <user name>\SendTo
+sub CSIDL_STARTMENU () { 0x000B } # <user name>\Start Menu
+sub CSIDL_MYMUSIC () { 0x000D } # "My Music" folder
+sub CSIDL_MYVIDEO () { 0x000E } # "My Videos" folder
+sub CSIDL_DESKTOPDIRECTORY () { 0x0010 } # <user name>\Desktop
+sub CSIDL_NETHOOD () { 0x0013 } # <user name>\nethood
+sub CSIDL_FONTS () { 0x0014 } # windows\fonts
+sub CSIDL_TEMPLATES () { 0x0015 }
+sub CSIDL_COMMON_STARTMENU () { 0x0016 } # All Users\Start Menu
+sub CSIDL_COMMON_PROGRAMS () { 0x0017 } # All Users\Start Menu\Programs
+sub CSIDL_COMMON_STARTUP () { 0x0018 } # All Users\Startup
+sub CSIDL_COMMON_DESKTOPDIRECTORY () { 0x0019 } # All Users\Desktop
+sub CSIDL_APPDATA () { 0x001A } # Application Data, new for NT4
+sub CSIDL_PRINTHOOD () { 0x001B } # <user name>\PrintHood
+sub CSIDL_LOCAL_APPDATA () { 0x001C } # non roaming, user\Local Settings\Application Data
+sub CSIDL_COMMON_FAVORITES () { 0x001F }
+sub CSIDL_INTERNET_CACHE () { 0x0020 }
+sub CSIDL_COOKIES () { 0x0021 }
+sub CSIDL_HISTORY () { 0x0022 }
+sub CSIDL_COMMON_APPDATA () { 0x0023 } # All Users\Application Data
+sub CSIDL_WINDOWS () { 0x0024 } # GetWindowsDirectory()
+sub CSIDL_SYSTEM () { 0x0025 } # GetSystemDirectory()
+sub CSIDL_PROGRAM_FILES () { 0x0026 } # C:\Program Files
+sub CSIDL_MYPICTURES () { 0x0027 } # "My Pictures", new for Win2K
+sub CSIDL_PROFILE () { 0x0028 } # USERPROFILE
+sub CSIDL_PROGRAM_FILES_COMMON () { 0x002B } # C:\Program Files\Common
+sub CSIDL_COMMON_TEMPLATES () { 0x002D } # All Users\Templates
+sub CSIDL_COMMON_DOCUMENTS () { 0x002E } # All Users\Documents
+sub CSIDL_COMMON_ADMINTOOLS () { 0x002F } # All Users\Start Menu\Programs\Administrative Tools
+sub CSIDL_ADMINTOOLS () { 0x0030 } # <user name>\Start Menu\Programs\Administrative Tools
+sub CSIDL_COMMON_MUSIC () { 0x0035 } # All Users\My Music
+sub CSIDL_COMMON_PICTURES () { 0x0036 } # All Users\My Pictures
+sub CSIDL_COMMON_VIDEO () { 0x0037 } # All Users\My Video
+sub CSIDL_RESOURCES () { 0x0038 } # %windir%\Resources\, For theme and other windows resources.
+sub CSIDL_RESOURCES_LOCALIZED () { 0x0039 } # %windir%\Resources\<LangID>, for theme and other windows specific resources.
+sub CSIDL_CDBURN_AREA () { 0x003B } # <user name>\Local Settings\Application Data\Microsoft\CD Burning
+
+### This method is just a simple interface into GetOSVersion(). More
+### specific or demanding situations should use that instead.
+
+my ($cached_os, $cached_desc);
+
+sub GetOSName {
+ unless (defined $cached_os) {
+ my($desc, $major, $minor, $build, $id, undef, undef, undef, $producttype)
+ = Win32::GetOSVersion();
+ ($cached_os, $cached_desc) = _GetOSName($desc, $major, $minor, $build, $id, $producttype);
+ }
+ return wantarray ? ($cached_os, $cached_desc) : $cached_os;
+}
+
+sub _GetOSName {
+ my($desc, $major, $minor, $build, $id, $producttype) = @_;
+
+ my($os,$tag);
+ if ($id == 0) {
+ $os = "Win32s";
+ }
+ elsif ($id == 1) {
+ $os = { 0 => "95", 10 => "98", 90 => "Me" }->{$minor};
+ }
+ elsif ($id == 2) {
+ if ($major == 3) {
+ $os = "NT3.51";
+ }
+ elsif ($major == 4) {
+ $os = "NT4";
+ }
+ elsif ($major == 5) {
+ $os = { 0 => "2000", 1 => "XP/.Net", 2 => "2003" }->{$minor};
+ }
+ elsif ($major == 6) {
+ $os = { 0 => "Vista", 1 => "7" }->{$minor};
+ # 2008 is same as Vista but has "Domaincontroller" or "Server" type
+ $os = "2008" if $os eq "Vista" && $producttype != 1;
+ }
+ }
+
+ unless (defined $os) {
+ warn "Unknown Windows version [$id:$major:$minor]";
+ return;
+ }
+
+ # Take a look at the build numbers and try to deduce
+ # the exact release name, but we put that in the $desc
+ if ($os eq "95") {
+ $tag = { 67109814 => "(a)", 67306684 => "(b1)", "67109975" => "(b2)" }->{$build};
+ }
+ elsif ($os eq "98" && $build eq "67766446") {
+ $tag = "(2nd ed)";
+ }
+ if ($tag) {
+ $desc = length($desc) ? "$tag $desc" : $tag;
+ }
+
+ return ("Win$os", $desc);
+}
+
+# "no warnings 'redefine';" doesn't work for 5.8.7 and earlier
+local $^W = 0;
+bootstrap Win32;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32 - Interfaces to some Win32 API Functions
+
+=head1 DESCRIPTION
+
+The Win32 module contains functions to access Win32 APIs.
+
+=head2 Alphabetical Listing of Win32 Functions
+
+It is recommended to C<use Win32;> before any of these functions;
+however, for backwards compatibility, those marked as [CORE] will
+automatically do this for you.
+
+In the function descriptions below the term I<Unicode string> is used
+to indicate that the string may contain characters outside the system
+codepage. The caveat I<If supported by the core Perl version>
+generally means Perl 5.8.9 and later, though some Unicode pathname
+functionality may work on earlier versions.
+
+=over
+
+=item Win32::AbortSystemShutdown(MACHINE)
+
+Aborts a system shutdown (started by the
+InitiateSystemShutdown function) on the specified MACHINE.
+
+=item Win32::BuildNumber()
+
+[CORE] Returns the ActivePerl build number. This function is
+only available in the ActivePerl binary distribution.
+
+=item Win32::CopyFile(FROM, TO, OVERWRITE)
+
+[CORE] The Win32::CopyFile() function copies an existing file to a new
+file. All file information like creation time and file attributes will
+be copied to the new file. However it will B<not> copy the security
+information. If the destination file already exists it will only be
+overwritten when the OVERWRITE parameter is true. But even this will
+not overwrite a read-only file; you have to unlink() it first
+yourself.
+
+=item Win32::CreateDirectory(DIRECTORY)
+
+Creates the DIRECTORY and returns a true value on success. Check $^E
+on failure for extended error information.
+
+DIRECTORY may contain Unicode characters outside the system codepage.
+Once the directory has been created you can use
+Win32::GetANSIPathName() to get a name that can be passed to system
+calls and external programs.
+
+=item Win32::CreateFile(FILE)
+
+Creates the FILE and returns a true value on success. Check $^E on
+failure for extended error information.
+
+FILE may contain Unicode characters outside the system codepage. Once
+the file has been created you can use Win32::GetANSIPathName() to get
+a name that can be passed to system calls and external programs.
+
+=item Win32::DomainName()
+
+[CORE] Returns the name of the Microsoft Network domain or workgroup
+that the owner of the current perl process is logged into. The
+"Workstation" service must be running to determine this
+information. This function does B<not> work on Windows 9x.
+
+=item Win32::ExpandEnvironmentStrings(STRING)
+
+Takes STRING and replaces all referenced environment variable
+names with their defined values. References to environment variables
+take the form C<%VariableName%>. Case is ignored when looking up the
+VariableName in the environment. If the variable is not found then the
+original C<%VariableName%> text is retained. Has the same effect
+as the following:
+
+ $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg
+
+However, this function may return a Unicode string if the environment
+variable being expanded hasn't been assigned to via %ENV. Access
+to %ENV is currently always using byte semantics.
+
+=item Win32::FormatMessage(ERRORCODE)
+
+[CORE] Converts the supplied Win32 error number (e.g. returned by
+Win32::GetLastError()) to a descriptive string. Analogous to the
+perror() standard-C library function. Note that C<$^E> used
+in a string context has much the same effect.
+
+ C:\> perl -e "$^E = 26; print $^E;"
+ The specified disk or diskette cannot be accessed
+
+=item Win32::FsType()
+
+[CORE] Returns the name of the filesystem of the currently active
+drive (like 'FAT' or 'NTFS'). In list context it returns three values:
+(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as
+before. FLAGS is a combination of values of the following table:
+
+ 0x00000001 supports case-sensitive filenames
+ 0x00000002 preserves the case of filenames
+ 0x00000004 supports Unicode in filenames
+ 0x00000008 preserves and enforces ACLs
+ 0x00000010 supports file-based compression
+ 0x00000020 supports disk quotas
+ 0x00000040 supports sparse files
+ 0x00000080 supports reparse points
+ 0x00000100 supports remote storage
+ 0x00008000 is a compressed volume (e.g. DoubleSpace)
+ 0x00010000 supports object identifiers
+ 0x00020000 supports the Encrypted File System (EFS)
+
+MAXCOMPLEN is the maximum length of a filename component (the part
+between two backslashes) on this file system.
+
+=item Win32::FreeLibrary(HANDLE)
+
+Unloads a previously loaded dynamic-link library. The HANDLE is
+no longer valid after this call. See L<LoadLibrary|Win32::LoadLibrary(LIBNAME)>
+for information on dynamically loading a library.
+
+=item Win32::GetANSIPathName(FILENAME)
+
+Returns an ANSI version of FILENAME. This may be the short name
+if the long name cannot be represented in the system codepage.
+
+While not currently implemented, it is possible that in the future
+this function will convert only parts of the path to FILENAME to a
+short form.
+
+If FILENAME doesn't exist on the filesystem, or if the filesystem
+doesn't support short ANSI filenames, then this function will
+translate the Unicode name into the system codepage using replacement
+characters.
+
+=item Win32::GetArchName()
+
+Use of this function is deprecated. It is equivalent with
+$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X.
+
+=item Win32::GetChipName()
+
+Returns the processor type: 386, 486 or 586 for Intel processors,
+21064 for the Alpha chip.
+
+=item Win32::GetCwd()
+
+[CORE] Returns the current active drive and directory. This function
+does not return a UNC path, since the functionality required for such
+a feature is not available under Windows 95.
+
+If supported by the core Perl version, this function will return an
+ANSI path name for the current directory if the long pathname cannot
+be represented in the system codepage.
+
+=item Win32::GetCurrentProcessId()
+
+Returns the process identifier of the current process. Until the
+process terminates, the process identifier uniquely identifies the
+process throughout the system.
+
+The current process identifier is normally also available via the
+predefined $$ variable. Under fork() emulation however $$ may contain
+a pseudo-process identifier that is only meaningful to the Perl
+kill(), wait() and waitpid() functions. The
+Win32::GetCurrentProcessId() function will always return the regular
+Windows process id, even when called from inside a pseudo-process.
+
+=item Win32::GetCurrentThreadId()
+
+Returns the thread identifier of the calling thread. Until the thread
+terminates, the thread identifier uniquely identifies the thread
+throughout the system.
+
+=item Win32::GetFileVersion(FILENAME)
+
+Returns the file version number from the VERSIONINFO resource of
+the executable file or DLL. This is a tuple of four 16 bit numbers.
+In list context these four numbers will be returned. In scalar context
+they are concatenated into a string, separated by dots.
+
+=item Win32::GetFolderPath(FOLDER [, CREATE])
+
+Returns the full pathname of one of the Windows special folders.
+The folder will be created if it doesn't exist and the optional CREATE
+argument is true. The following FOLDER constants are defined by the
+Win32 module, but only exported on demand:
+
+ CSIDL_ADMINTOOLS
+ CSIDL_APPDATA
+ CSIDL_CDBURN_AREA
+ CSIDL_COMMON_ADMINTOOLS
+ CSIDL_COMMON_APPDATA
+ CSIDL_COMMON_DESKTOPDIRECTORY
+ CSIDL_COMMON_DOCUMENTS
+ CSIDL_COMMON_FAVORITES
+ CSIDL_COMMON_MUSIC
+ CSIDL_COMMON_PICTURES
+ CSIDL_COMMON_PROGRAMS
+ CSIDL_COMMON_STARTMENU
+ CSIDL_COMMON_STARTUP
+ CSIDL_COMMON_TEMPLATES
+ CSIDL_COMMON_VIDEO
+ CSIDL_COOKIES
+ CSIDL_DESKTOP
+ CSIDL_DESKTOPDIRECTORY
+ CSIDL_FAVORITES
+ CSIDL_FONTS
+ CSIDL_HISTORY
+ CSIDL_INTERNET_CACHE
+ CSIDL_LOCAL_APPDATA
+ CSIDL_MYMUSIC
+ CSIDL_MYPICTURES
+ CSIDL_MYVIDEO
+ CSIDL_NETHOOD
+ CSIDL_PERSONAL
+ CSIDL_PRINTHOOD
+ CSIDL_PROFILE
+ CSIDL_PROGRAMS
+ CSIDL_PROGRAM_FILES
+ CSIDL_PROGRAM_FILES_COMMON
+ CSIDL_RECENT
+ CSIDL_RESOURCES
+ CSIDL_RESOURCES_LOCALIZED
+ CSIDL_SENDTO
+ CSIDL_STARTMENU
+ CSIDL_STARTUP
+ CSIDL_SYSTEM
+ CSIDL_TEMPLATES
+ CSIDL_WINDOWS
+
+Note that not all folders are defined on all versions of Windows.
+
+Please refer to the MSDN documentation of the CSIDL constants,
+currently available at:
+
+http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/enums/csidl.asp
+
+This function will return an ANSI folder path if the long name cannot
+be represented in the system codepage. Use Win32::GetLongPathName()
+on the result of Win32::GetFolderPath() if you want the Unicode
+version of the folder name.
+
+=item Win32::GetFullPathName(FILENAME)
+
+[CORE] GetFullPathName combines the FILENAME with the current drive
+and directory name and returns a fully qualified (aka, absolute)
+path name. In list context it returns two elements: (PATH, FILE) where
+PATH is the complete pathname component (including trailing backslash)
+and FILE is just the filename part. Note that no attempt is made to
+convert 8.3 components in the supplied FILENAME to longnames or
+vice-versa. Compare with Win32::GetShortPathName() and
+Win32::GetLongPathName().
+
+If supported by the core Perl version, this function will return an
+ANSI path name if the full pathname cannot be represented in the
+system codepage.
+
+=item Win32::GetLastError()
+
+[CORE] Returns the last error value generated by a call to a Win32 API
+function. Note that C<$^E> used in a numeric context amounts to the
+same value.
+
+=item Win32::GetLongPathName(PATHNAME)
+
+[CORE] Returns a representation of PATHNAME composed of longname
+components (if any). The result may not necessarily be longer
+than PATHNAME. No attempt is made to convert PATHNAME to the
+absolute path. Compare with Win32::GetShortPathName() and
+Win32::GetFullPathName().
+
+This function may return the pathname in Unicode if it cannot be
+represented in the system codepage. Use Win32::GetANSIPathName()
+before passing the path to a system call or another program.
+
+=item Win32::GetNextAvailDrive()
+
+[CORE] Returns a string in the form of "<d>:" where <d> is the first
+available drive letter.
+
+=item Win32::GetOSVersion()
+
+[CORE] Returns the list (STRING, MAJOR, MINOR, BUILD, ID), where the
+elements are, respectively: An arbitrary descriptive string, the major
+version number of the operating system, the minor version number, the
+build number, and a digit indicating the actual operating system.
+For the ID, the values are 0 for Win32s, 1 for Windows 9X/Me and 2 for
+Windows NT/2000/XP/2003/Vista/2008/7. In scalar context it returns just
+the ID.
+
+Currently known values for ID MAJOR and MINOR are as follows:
+
+ OS ID MAJOR MINOR
+ Win32s 0 - -
+ Windows 95 1 4 0
+ Windows 98 1 4 10
+ Windows Me 1 4 90
+ Windows NT 3.51 2 3 51
+ Windows NT 4 2 4 0
+ Windows 2000 2 5 0
+ Windows XP 2 5 1
+ Windows Server 2003 2 5 2
+ Windows Vista 2 6 0
+ Windows Server 2008 2 6 0
+ Windows 7 2 6 1
+
+On Windows NT 4 SP6 and later this function returns the following
+additional values: SPMAJOR, SPMINOR, SUITEMASK, PRODUCTTYPE.
+
+The version numbers for Windows Vista and Windows Server 2008 are
+identical; the PRODUCTTYPE field must be used to differentiate
+between them.
+
+SPMAJOR and SPMINOR are are the version numbers of the latest
+installed service pack.
+
+SUITEMASK is a bitfield identifying the product suites available on
+the system. Known bits are:
+
+ VER_SUITE_SMALLBUSINESS 0x00000001
+ VER_SUITE_ENTERPRISE 0x00000002
+ VER_SUITE_BACKOFFICE 0x00000004
+ VER_SUITE_COMMUNICATIONS 0x00000008
+ VER_SUITE_TERMINAL 0x00000010
+ VER_SUITE_SMALLBUSINESS_RESTRICTED 0x00000020
+ VER_SUITE_EMBEDDEDNT 0x00000040
+ VER_SUITE_DATACENTER 0x00000080
+ VER_SUITE_SINGLEUSERTS 0x00000100
+ VER_SUITE_PERSONAL 0x00000200
+ VER_SUITE_BLADE 0x00000400
+ VER_SUITE_EMBEDDED_RESTRICTED 0x00000800
+ VER_SUITE_SECURITY_APPLIANCE 0x00001000
+
+The VER_SUITE_xxx names are listed here to crossreference the Microsoft
+documentation. The Win32 module does not provide symbolic names for these
+constants.
+
+PRODUCTTYPE provides additional information about the system. It should
+be one of the following integer values:
+
+ 1 - Workstation (NT 4, 2000 Pro, XP Home, XP Pro, Vista)
+ 2 - Domaincontroller
+ 3 - Server (2000 Server, Server 2003, Server 2008)
+
+Note that a server that is also a domain controller is reported as
+PRODUCTTYPE 2 (Domaincontroller) and not PRODUCTTYPE 3 (Server).
+
+=item Win32::GetOSName()
+
+In scalar context returns the name of the Win32 operating system
+being used. In list context returns a two element list of the OS name
+and whatever edition information is known about the particular build
+(for Win9X boxes) and whatever service packs have been installed.
+The latter is roughly equivalent to the first item returned by
+GetOSVersion() in list context.
+
+Currently the possible values for the OS name are
+
+ WinWin32s
+ Win95
+ Win98
+ WinMe
+ WinNT3.51
+ WinNT4
+ Win2000
+ WinXP/.Net
+ Win2003
+ WinVista
+ Win2008
+ Win7
+
+This routine is just a simple interface into GetOSVersion(). More
+specific or demanding situations should use that instead. Another
+option would be to use POSIX::uname(), however the latter appears to
+report only the OS family name and not the specific OS. In scalar
+context it returns just the ID.
+
+The name "WinXP/.Net" is used for historical reasons only, to maintain
+backwards compatibility of the Win32 module. Windows .NET Server has
+been renamed as Windows 2003 Server before final release and uses a
+different major/minor version number than Windows XP.
+
+Similarly the name "WinWin32s" should have been "Win32s" but has been
+kept as-is for backwards compatibility reasons too.
+
+=item Win32::GetShortPathName(PATHNAME)
+
+[CORE] Returns a representation of PATHNAME that is composed of short
+(8.3) path components where available. For path components where the
+file system has not generated the short form the returned path will
+use the long form, so this function might still for instance return a
+path containing spaces. Returns C<undef> when the PATHNAME does not
+exist. Compare with Win32::GetFullPathName() and
+Win32::GetLongPathName().
+
+=item Win32::GetProcAddress(INSTANCE, PROCNAME)
+
+Returns the address of a function inside a loaded library. The
+information about what you can do with this address has been lost in
+the mist of time. Use the Win32::API module instead of this deprecated
+function.
+
+=item Win32::GetTickCount()
+
+[CORE] Returns the number of milliseconds elapsed since the last
+system boot. Resolution is limited to system timer ticks (about 10ms
+on WinNT and 55ms on Win9X).
+
+=item Win32::GuidGen()
+
+Creates a globally unique 128 bit integer that can be used as a
+persistent identifier in a distributed setting. To a very high degree
+of certainty this function returns a unique value. No other
+invocation, on the same or any other system (networked or not), should
+return the same value.
+
+The return value is formatted according to OLE conventions, as groups
+of hex digits with surrounding braces. For example:
+
+ {09531CF1-D0C7-4860-840C-1C8C8735E2AD}
+
+=item Win32::InitiateSystemShutdown
+
+(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT)
+
+Shutsdown the specified MACHINE, notifying users with the
+supplied MESSAGE, within the specified TIMEOUT interval. Forces
+closing of all documents without prompting the user if FORCECLOSE is
+true, and reboots the machine if REBOOT is true. This function works
+only on WinNT.
+
+=item Win32::IsAdminUser()
+
+Returns non zero if the account in whose security context the
+current process/thread is running belongs to the local group of
+Administrators in the built-in system domain; returns 0 if not.
+On Windows Vista it will only return non-zero if the process is
+actually running with elevated privileges. Returns C<undef>
+and prints a warning if an error occurred. This function always
+returns 1 on Win9X.
+
+=item Win32::IsWinNT()
+
+[CORE] Returns non zero if the Win32 subsystem is Windows NT.
+
+=item Win32::IsWin95()
+
+[CORE] Returns non zero if the Win32 subsystem is Windows 95.
+
+=item Win32::LoadLibrary(LIBNAME)
+
+Loads a dynamic link library into memory and returns its module
+handle. This handle can be used with Win32::GetProcAddress() and
+Win32::FreeLibrary(). This function is deprecated. Use the Win32::API
+module instead.
+
+=item Win32::LoginName()
+
+[CORE] Returns the username of the owner of the current perl process.
+The return value may be a Unicode string.
+
+=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE)
+
+Looks up ACCOUNT on SYSTEM and returns the domain name the SID and
+the SID type.
+
+=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE)
+
+Looks up SID on SYSTEM and returns the account name, domain name,
+and the SID type.
+
+=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]])
+
+Create a dialogbox containing MESSAGE. FLAGS specifies the
+required icon and buttons according to the following table:
+
+ 0 = OK
+ 1 = OK and Cancel
+ 2 = Abort, Retry, and Ignore
+ 3 = Yes, No and Cancel
+ 4 = Yes and No
+ 5 = Retry and Cancel
+
+ MB_ICONSTOP "X" in a red circle
+ MB_ICONQUESTION question mark in a bubble
+ MB_ICONEXCLAMATION exclamation mark in a yellow triangle
+ MB_ICONINFORMATION "i" in a bubble
+
+TITLE specifies an optional window title. The default is "Perl".
+
+The function returns the menu id of the selected push button:
+
+ 0 Error
+
+ 1 OK
+ 2 Cancel
+ 3 Abort
+ 4 Retry
+ 5 Ignore
+ 6 Yes
+ 7 No
+
+=item Win32::NodeName()
+
+[CORE] Returns the Microsoft Network node-name of the current machine.
+
+=item Win32::OutputDebugString(STRING)
+
+Sends a string to the application or system debugger for display.
+The function does nothing if there is no active debugger.
+
+Alternatively one can use the I<Debug Viewer> application to
+watch the OutputDebugString() output:
+
+http://www.microsoft.com/technet/sysinternals/utilities/debugview.mspx
+
+=item Win32::RegisterServer(LIBRARYNAME)
+
+Loads the DLL LIBRARYNAME and calls the function DllRegisterServer.
+
+=item Win32::SetChildShowWindow(SHOWWINDOW)
+
+[CORE] Sets the I<ShowMode> of child processes started by system().
+By default system() will create a new console window for child
+processes if Perl itself is not running from a console. Calling
+SetChildShowWindow(0) will make these new console windows invisible.
+Calling SetChildShowWindow() without arguments reverts system() to the
+default behavior. The return value of SetChildShowWindow() is the
+previous setting or C<undef>.
+
+The following symbolic constants for SHOWWINDOW are available
+(but not exported) from the Win32 module: SW_HIDE, SW_SHOWNORMAL,
+SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED and SW_SHOWNOACTIVATE.
+
+=item Win32::SetCwd(NEWDIRECTORY)
+
+[CORE] Sets the current active drive and directory. This function does not
+work with UNC paths, since the functionality required to required for
+such a feature is not available under Windows 95.
+
+=item Win32::SetLastError(ERROR)
+
+[CORE] Sets the value of the last error encountered to ERROR. This is
+that value that will be returned by the Win32::GetLastError()
+function.
+
+=item Win32::Sleep(TIME)
+
+[CORE] Pauses for TIME milliseconds. The timeslices are made available
+to other processes and threads.
+
+=item Win32::Spawn(COMMAND, ARGS, PID)
+
+[CORE] Spawns a new process using the supplied COMMAND, passing in
+arguments in the string ARGS. The pid of the new process is stored in
+PID. This function is deprecated. Please use the Win32::Process module
+instead.
+
+=item Win32::UnregisterServer(LIBRARYNAME)
+
+Loads the DLL LIBRARYNAME and calls the function
+DllUnregisterServer.
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Win32CORE.pm b/Master/tlpkg/tlperl/lib/Win32CORE.pm
new file mode 100644
index 00000000000..0e5d20bb908
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Win32CORE.pm
@@ -0,0 +1,38 @@
+package Win32CORE;
+
+$VERSION = '0.02';
+
+# There is no reason to load this module explicitly. It will be
+# initialized using xs_init() when the interpreter is constructed.
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32CORE - Win32 CORE function stubs
+
+=head1 DESCRIPTION
+
+This library provides stubs for the functions marked as [CORE] in L<Win32>.
+See that document for usage information. When any of these functions are
+called, the full Win32 module is loaded automatically. It is preferred
+that callers of these functions explicitly C<use Win32;>.
+
+=head1 HISTORY
+
+Win32CORE was created to provide on cygwin those Win32:: functions that
+for regular win32 builds were provided by default in perl. In cygwin
+perl releases prior to 5.8.6, this module was standalone and had to
+be explicitly used. In 5.8.6 and later, it was statically linked into
+cygwin perl so this would no longer be necessary.
+
+As of perl 5.9.5/Win32 0.27, these functions have been moved into
+the Win32 module. Win32CORE provides stubs for each of the former
+CORE Win32:: functions that internally just load the Win32 module and
+call it's version, and Win32CORE is statically linked to perl for both
+cygwin and regular win32 builds. This will permit these functions to
+be updated in the CPAN Win32 module independently of updating perl.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/XSLoader.pm b/Master/tlpkg/tlperl/lib/XSLoader.pm
new file mode 100644
index 00000000000..98ed299d8b3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/XSLoader.pm
@@ -0,0 +1,358 @@
+# Generated from XSLoader.pm.PL (resolved %Config::Config value)
+
+package XSLoader;
+
+$VERSION = "0.10";
+
+#use strict;
+
+# enable debug/trace messages from DynaLoader perl code
+# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+ my $dl_dlext = 'dll';
+
+package DynaLoader;
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_error);
+package XSLoader;
+
+sub load {
+ package DynaLoader;
+
+ die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
+
+ my($module) = $_[0];
+
+ # work with static linking too
+ my $boots = "$module\::bootstrap";
+ goto &$boots if defined &$boots;
+
+ goto retry unless $module and defined &dl_load_file;
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+ my $modpname = join('/',@modparts);
+ my $modlibname = (caller())[1];
+ my $c = @modparts;
+ $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
+ my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
+
+# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
+
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
+
+ if (-s $bs) { # only read file if it's not empty
+# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
+ eval { do $bs; };
+ warn "$bs: $@\n" if $@;
+ }
+
+ goto retry if not -f $file or -s $bs;
+
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @DynaLoader::dl_require_symbols = ($bootname);
+
+ my $boot_symbol_ref;
+
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, 0) or do {
+ require Carp;
+ Carp::croak("Can't load '$file' for module $module: " . dl_error());
+ };
+ push(@DynaLoader::dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
+ require Carp;
+ Carp::croak("Can't find '$bootname' symbol in $file\n");
+ };
+
+ push(@DynaLoader::dl_modules, $module); # record loaded module
+
+ boot:
+ my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file);
+
+ # See comment block above
+ push(@DynaLoader::dl_shared_objects, $file); # record files loaded
+ return &$xs(@_);
+
+ retry:
+ my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
+ XSLoader->can('bootstrap_inherit');
+ goto &$bootstrap_inherit;
+}
+
+# Versions of DynaLoader prior to 5.6.0 don't have this function.
+sub bootstrap_inherit {
+ package DynaLoader;
+
+ my $module = $_[0];
+ local *DynaLoader::isa = *{"$module\::ISA"};
+ local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
+ # Cannot goto due to delocalization. Will report errors on a wrong line?
+ require DynaLoader;
+ DynaLoader::bootstrap(@_);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+XSLoader - Dynamically load C libraries into Perl code
+
+=head1 VERSION
+
+Version 0.10
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ use XSLoader;
+
+ XSLoader::load 'YourPackage', $YourPackage::VERSION;
+
+=head1 DESCRIPTION
+
+This module defines a standard I<simplified> interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement cheap automatic dynamic loading of Perl modules.
+
+For a more complicated interface, see L<DynaLoader>. Many (most)
+features of C<DynaLoader> are not implemented in C<XSLoader>, like for
+example the C<dl_load_flags>, not honored by C<XSLoader>.
+
+=head2 Migration from C<DynaLoader>
+
+A typical module using L<DynaLoader|DynaLoader> starts like this:
+
+ package YourPackage;
+ require DynaLoader;
+
+ our @ISA = qw( OnePackage OtherPackage DynaLoader );
+ our $VERSION = '0.01';
+ bootstrap YourPackage $VERSION;
+
+Change this to
+
+ package YourPackage;
+ use XSLoader;
+
+ our @ISA = qw( OnePackage OtherPackage );
+ our $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+
+In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
+C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
+forget to quote the name of your package on the C<XSLoader::load> line,
+and add comma (C<,>) before the arguments (C<$VERSION> above).
+
+Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
+the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
+more backward-compatible
+
+ use vars qw($VERSION @ISA);
+
+one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
+
+If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
+
+ XSLoader::load 'YourPackage';
+
+=head2 Backward compatible boilerplate
+
+If you want to have your cake and eat it too, you need a more complicated
+boilerplate.
+
+ package YourPackage;
+ use vars qw($VERSION @ISA);
+
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ eval {
+ require XSLoader;
+ XSLoader::load('YourPackage', $VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ bootstrap YourPackage $VERSION;
+ };
+
+The parentheses about C<XSLoader::load()> arguments are needed since we replaced
+C<use XSLoader> by C<require>, so the compiler does not know that a function
+C<XSLoader::load()> is present.
+
+This boilerplate uses the low-overhead C<XSLoader> if present; if used with
+an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
+
+=head1 Order of initialization: early load()
+
+I<Skip this section if the XSUB functions are supposed to be called from other
+modules only; read it only if you call your XSUBs from the code in your module,
+or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
+What is described here is equally applicable to the L<DynaLoader|DynaLoader>
+interface.>
+
+A sufficiently complicated module using XS would have both Perl code (defined
+in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
+Perl code makes calls into this XS code, and/or this XS code makes calls to
+the Perl code, one should be careful with the order of initialization.
+
+The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
+
+=over
+
+=item *
+
+if C<$VERSION> was specified, a sanity check is done to ensure that the
+versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
+
+=item *
+
+the XSUBs are made accessible from Perl;
+
+=item *
+
+if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
+
+=back
+
+Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
+convenient to have XSUBs installed before the Perl code is defined; for
+example, this makes prototypes for XSUBs visible to this Perl code.
+Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
+uses Perl variables) defined in the F<.pm> file, they must be defined prior to
+the call to C<XSLoader::load()> (or C<bootstrap()>).
+
+The first situation being much more frequent, it makes sense to rewrite the
+boilerplate as
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+
+ # Put Perl code used in the BOOT: section here
+
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code making calls into XSUBs here
+
+=head2 The most hairy case
+
+If the interdependence of your C<BOOT:> section and Perl code is
+more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
+functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
+section altogether. Replace it with a function C<onBOOT()>, and call it like
+this:
+
+ package YourPackage;
+ use XSLoader;
+ use vars qw($VERSION @ISA);
+
+ BEGIN {
+ @ISA = qw( OnePackage OtherPackage );
+ $VERSION = '0.01';
+ XSLoader::load 'YourPackage', $VERSION;
+ }
+
+ # Put Perl code used in onBOOT() function here; calls to XSUBs are
+ # prototype-checked.
+
+ onBOOT;
+
+ # Put Perl initialization code assuming that XS is initialized here
+
+
+=head1 DIAGNOSTICS
+
+=over
+
+=item C<Can't find '%s' symbol in %s>
+
+B<(F)> The bootstrap symbol could not be found in the extension module.
+
+=item C<Can't load '%s' for module %s: %s>
+
+B<(F)> The loading or initialisation of the extension module failed.
+The detailed error follows.
+
+=item C<Undefined symbols present after loading %s: %s>
+
+B<(W)> As the message says, some symbols stay undefined although the
+extension module was correctly loaded and initialised. The list of undefined
+symbols follows.
+
+=item C<XSLoader::load('Your::Module', $Your::Module::VERSION)>
+
+B<(F)> You tried to invoke C<load()> without any argument. You must supply
+a module name, and optionally its version.
+
+=back
+
+
+=head1 LIMITATIONS
+
+To reduce the overhead as much as possible, only one possible location
+is checked to find the extension DLL (this location is where C<make install>
+would put the DLL). If not found, the search for the DLL is transparently
+delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
+
+In particular, this is applicable to the structure of C<@INC> used for testing
+not-yet-installed extensions. This means that running uninstalled extensions
+may have much more overhead than running the same extensions after
+C<make install>.
+
+
+=head1 BUGS
+
+Please report any bugs or feature requests via the perlbug(1) utility.
+
+
+=head1 SEE ALSO
+
+L<DynaLoader>
+
+
+=head1 AUTHORS
+
+Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
+
+CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
+E<lt>sebastien@aperghis.netE<gt>.
+
+Previous maintainer was Michael G Schwern <schwern@pobox.com>.
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (C) 1990-2007 by Larry Wall and others.
+
+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/abbrev.pl b/Master/tlpkg/tlperl/lib/abbrev.pl
new file mode 100644
index 00000000000..cd20063f003
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/abbrev.pl
@@ -0,0 +1,45 @@
+;# Usage:
+;# %foo = ();
+;# &abbrev(*foo,LIST);
+;# ...
+;# $long = $foo{$short};
+
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Text::Abbrev
+#
+
+package abbrev;
+
+sub main'abbrev {
+ local(*domain) = @_;
+ shift(@_);
+ @cmp = @_;
+ local($[) = 0;
+ foreach $name (@_) {
+ @extra = split(//,$name);
+ $abbrev = shift(@extra);
+ $len = 1;
+ foreach $cmp (@cmp) {
+ next if $cmp eq $name;
+ while (@extra && substr($cmp,0,$len) eq $abbrev) {
+ $abbrev .= shift(@extra);
+ ++$len;
+ }
+ }
+ $domain{$abbrev} = $name;
+ while ($#extra >= 0) {
+ $abbrev .= shift(@extra);
+ $domain{$abbrev} = $name;
+ }
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/assert.pl b/Master/tlpkg/tlperl/lib/assert.pl
new file mode 100644
index 00000000000..2c2073c7eaa
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/assert.pl
@@ -0,0 +1,61 @@
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# assert.pl
+# tchrist@convex.com (Tom Christiansen)
+#
+# Usage:
+#
+# &assert('@x > @y');
+# &assert('$var > 10', $var, $othervar, @various_info);
+#
+# That is, if the first expression evals false, we blow up. The
+# rest of the args, if any, are nice to know because they will
+# be printed out by &panic, which is just the stack-backtrace
+# routine shamelessly borrowed from the perl debugger.
+
+sub assert {
+ &panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[];
+}
+
+sub panic {
+ package DB;
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ # stack traceback gratefully borrowed from perl debugger
+
+ local $_;
+ my $i;
+ my ($p,$f,$l,$s,$h,$a,@a,@frames);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@frames, "$w&$s$a from file $f line $l\n");
+ }
+ for ($i=0; $i <= $#frames; $i++) {
+ print $frames[$i];
+ }
+ exit 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/attributes.pm b/Master/tlpkg/tlperl/lib/attributes.pm
new file mode 100644
index 00000000000..c117bef2003
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/attributes.pm
@@ -0,0 +1,490 @@
+package attributes;
+
+our $VERSION = 0.12;
+
+@EXPORT_OK = qw(get reftype);
+@EXPORT = ();
+%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
+
+use strict;
+
+sub croak {
+ require Carp;
+ goto &Carp::croak;
+}
+
+sub carp {
+ require Carp;
+ goto &Carp::carp;
+}
+
+my %deprecated;
+$deprecated{CODE} = qr/\A-?(locked)\z/;
+$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR}
+ = qr/\A-?(unique)\z/;
+
+sub _modify_attrs_and_deprecate {
+ my $svtype = shift;
+ # Now that we've removed handling of locked from the XS code, we need to
+ # remove it here, else it ends up in @badattrs. (If we do the deprecation in
+ # XS, we can't control the warning based on *our* caller's lexical settings,
+ # and the warned line is in this package)
+ grep {
+ $deprecated{$svtype} && /$deprecated{$svtype}/ ? do {
+ require warnings;
+ warnings::warnif('deprecated', "Attribute \"$1\" is deprecated");
+ 0;
+ } : 1
+ } _modify_attrs(@_);
+}
+
+sub import {
+ @_ > 2 && ref $_[2] or do {
+ require Exporter;
+ goto &Exporter::import;
+ };
+ my (undef,$home_stash,$svref,@attrs) = @_;
+
+ my $svtype = uc reftype($svref);
+ my $pkgmeth;
+ $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
+ if defined $home_stash && $home_stash ne '';
+ my @badattrs;
+ if ($pkgmeth) {
+ my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
+ @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
+ if (!@badattrs && @pkgattrs) {
+ require warnings;
+ return unless warnings::enabled('reserved');
+ @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
+ if (@pkgattrs) {
+ for my $attr (@pkgattrs) {
+ $attr =~ s/\(.+\z//s;
+ }
+ my $s = ((@pkgattrs == 1) ? '' : 's');
+ carp "$svtype package attribute$s " .
+ "may clash with future reserved word$s: " .
+ join(' : ' , @pkgattrs);
+ }
+ }
+ }
+ else {
+ @badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
+ }
+ if (@badattrs) {
+ croak "Invalid $svtype attribute" .
+ (( @badattrs == 1 ) ? '' : 's') .
+ ": " .
+ join(' : ', @badattrs);
+ }
+}
+
+sub get ($) {
+ @_ == 1 && ref $_[0] or
+ croak 'Usage: '.__PACKAGE__.'::get $ref';
+ my $svref = shift;
+ my $svtype = uc reftype($svref);
+ my $stash = _guess_stash($svref);
+ $stash = caller unless defined $stash;
+ my $pkgmeth;
+ $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
+ if defined $stash && $stash ne '';
+ return $pkgmeth ?
+ (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
+ (_fetch_attrs($svref))
+ ;
+}
+
+sub require_version { goto &UNIVERSAL::VERSION }
+
+require XSLoader;
+XSLoader::load('attributes', $VERSION);
+
+1;
+__END__
+#The POD goes here
+
+=head1 NAME
+
+attributes - get/set subroutine or variable attributes
+
+=head1 SYNOPSIS
+
+ sub foo : method ;
+ my ($x,@y,%z) : Bent = 1;
+ my $s = sub : method { ... };
+
+ use attributes (); # optional, to get subroutine declarations
+ my @attrlist = attributes::get(\&foo);
+
+ use attributes 'get'; # import the attributes::get subroutine
+ my @attrlist = get \&foo;
+
+=head1 DESCRIPTION
+
+Subroutine declarations and definitions may optionally have attribute lists
+associated with them. (Variable C<my> declarations also may, but see the
+warning below.) Perl handles these declarations by passing some information
+about the call site and the thing being declared along with the attribute
+list to this module. In particular, the first example above is equivalent to
+the following:
+
+ use attributes __PACKAGE__, \&foo, 'method';
+
+The second example in the synopsis does something equivalent to this:
+
+ use attributes ();
+ my ($x,@y,%z);
+ attributes::->import(__PACKAGE__, \$x, 'Bent');
+ attributes::->import(__PACKAGE__, \@y, 'Bent');
+ attributes::->import(__PACKAGE__, \%z, 'Bent');
+ ($x,@y,%z) = 1;
+
+Yes, that's a lot of expansion.
+
+B<WARNING>: attribute declarations for variables are still evolving.
+The semantics and interfaces of such declarations could change in
+future versions. They are present for purposes of experimentation
+with what the semantics ought to be. Do not rely on the current
+implementation of this feature.
+
+There are only a few attributes currently handled by Perl itself (or
+directly by this module, depending on how you look at it.) However,
+package-specific attributes are allowed by an extension mechanism.
+(See L<"Package-specific Attribute Handling"> below.)
+
+The setting of subroutine attributes happens at compile time.
+Variable attributes in C<our> declarations are also applied at compile time.
+However, C<my> variables get their attributes applied at run-time.
+This means that you have to I<reach> the run-time component of the C<my>
+before those attributes will get applied. For example:
+
+ my $x : Bent = 42 if 0;
+
+will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute
+to the variable.
+
+An attempt to set an unrecognized attribute is a fatal error. (The
+error is trappable, but it still stops the compilation within that
+C<eval>.) Setting an attribute with a name that's all lowercase
+letters that's not a built-in attribute (such as "foo") will result in
+a warning with B<-w> or C<use warnings 'reserved'>.
+
+=head2 What C<import> does
+
+In the description it is mentioned that
+
+ sub foo : method;
+
+is equivalent to
+
+ use attributes __PACKAGE__, \&foo, 'method';
+
+As you might know this calls the C<import> function of C<attributes> at compile
+time with these parameters: 'attributes', the caller's package name, the reference
+to the code and 'method'.
+
+ attributes->import( __PACKAGE__, \&foo, 'method' );
+
+So you want to know what C<import> actually does?
+
+First of all C<import> gets the type of the third parameter ('CODE' in this case).
+C<attributes.pm> checks if there is a subroutine called C<< MODIFY_<reftype>_ATTRIBUTES >>
+in the caller's namespace (here: 'main'). In this case a subroutine C<MODIFY_CODE_ATTRIBUTES> is
+required. Then this method is called to check if you have used a "bad attribute".
+The subroutine call in this example would look like
+
+ MODIFY_CODE_ATTRIBUTES( 'main', \&foo, 'method' );
+
+C<< MODIFY_<reftype>_ATTRIBUTES >> has to return a list of all "bad attributes".
+If there are any bad attributes C<import> croaks.
+
+(See L<"Package-specific Attribute Handling"> below.)
+
+=head2 Built-in Attributes
+
+The following are the built-in attributes for subroutines:
+
+=over 4
+
+=item lvalue
+
+Indicates that the referenced subroutine is a valid lvalue and can
+be assigned to. The subroutine must return a modifiable value such
+as a scalar variable, as described in L<perlsub>.
+
+=item method
+
+Indicates that the referenced subroutine is a method. A subroutine so marked
+will not trigger the "Ambiguous call resolved as CORE::%s" warning.
+
+=item locked
+
+The "locked" attribute has no effect in 5.10.0 and later. It was used as part
+of the now-removed "Perl 5.005 threads".
+
+=back
+
+=head2 Available Subroutines
+
+The following subroutines are available for general use once this module
+has been loaded:
+
+=over 4
+
+=item get
+
+This routine expects a single parameter--a reference to a
+subroutine or variable. It returns a list of attributes, which may be
+empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>)
+to raise a fatal exception. If it can find an appropriate package name
+for a class method lookup, it will include the results from a
+C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in
+L<"Package-specific Attribute Handling"> below.
+Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned.
+
+=item reftype
+
+This routine expects a single parameter--a reference to a subroutine or
+variable. It returns the built-in type of the referenced variable,
+ignoring any package into which it might have been blessed.
+This can be useful for determining the I<type> value which forms part of
+the method names described in L<"Package-specific Attribute Handling"> below.
+
+=back
+
+Note that these routines are I<not> exported by default.
+
+=head2 Package-specific Attribute Handling
+
+B<WARNING>: the mechanisms described here are still experimental. Do not
+rely on the current implementation. In particular, there is no provision
+for applying package attributes to 'cloned' copies of subroutines used as
+closures. (See L<perlref/"Making References"> for information on closures.)
+Package-specific attribute handling may change incompatibly in a future
+release.
+
+When an attribute list is present in a declaration, a check is made to see
+whether an attribute 'modify' handler is present in the appropriate package
+(or its @ISA inheritance tree). Similarly, when C<attributes::get> is
+called on a valid reference, a check is made for an appropriate attribute
+'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package"
+determination works.
+
+The handler names are based on the underlying type of the variable being
+declared or of the reference passed. Because these attributes are
+associated with subroutine or variable declarations, this deliberately
+ignores any possibility of being blessed into some package. Thus, a
+subroutine declaration uses "CODE" as its I<type>, and even a blessed
+hash reference uses "HASH" as its I<type>.
+
+The class methods invoked for modifying and fetching are these:
+
+=over 4
+
+=item FETCH_I<type>_ATTRIBUTES
+
+This method is called with two arguments: the relevant package name,
+and a reference to a variable or subroutine for which package-defined
+attributes are desired. The expected return value is a list of
+associated attributes. This list may be empty.
+
+=item MODIFY_I<type>_ATTRIBUTES
+
+This method is called with two fixed arguments, followed by the list of
+attributes from the relevant declaration. The two fixed arguments are
+the relevant package name and a reference to the declared subroutine or
+variable. The expected return value is a list of attributes which were
+not recognized by this handler. Note that this allows for a derived class
+to delegate a call to its base class, and then only examine the attributes
+which the base class didn't already handle for it.
+
+The call to this method is currently made I<during> the processing of the
+declaration. In particular, this means that a subroutine reference will
+probably be for an undefined subroutine, even if this declaration is
+actually part of the definition.
+
+=back
+
+Calling C<attributes::get()> from within the scope of a null package
+declaration C<package ;> for an unblessed variable reference will
+not provide any starting package name for the 'fetch' method lookup.
+Thus, this circumstance will not result in a method call for package-defined
+attributes. A named subroutine knows to which symbol table entry it belongs
+(or originally belonged), and it will use the corresponding package.
+An anonymous subroutine knows the package name into which it was compiled
+(unless it was also compiled with a null package declaration), and so it
+will use that package name.
+
+=head2 Syntax of Attribute Lists
+
+An attribute list is a sequence of attribute specifications, separated by
+whitespace or a colon (with optional whitespace).
+Each attribute specification is a simple
+name, optionally followed by a parenthesised parameter list.
+If such a parameter list is present, it is scanned past as for the rules
+for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.)
+The parameter list is passed as it was found, however, and not as per C<q()>.
+
+Some examples of syntactically valid attribute lists:
+
+ switch(10,foo(7,3)) : expensive
+ Ugly('\(") :Bad
+ _5x5
+ lvalue method
+
+Some examples of syntactically invalid attribute lists (with annotation):
+
+ switch(10,foo() # ()-string not balanced
+ Ugly('(') # ()-string not balanced
+ 5x5 # "5x5" not a valid identifier
+ Y2::north # "Y2::north" not a simple identifier
+ foo + bar # "+" neither a colon nor whitespace
+
+=head1 EXPORTS
+
+=head2 Default exports
+
+None.
+
+=head2 Available exports
+
+The routines C<get> and C<reftype> are exportable.
+
+=head2 Export tags defined
+
+The C<:ALL> tag will get all of the above exports.
+
+=head1 EXAMPLES
+
+Here are some samples of syntactically valid declarations, with annotation
+as to how they resolve internally into C<use attributes> invocations by
+perl. These examples are primarily useful to see how the "appropriate
+package" is found for the possible method lookups for package-defined
+attributes.
+
+=over 4
+
+=item 1.
+
+Code:
+
+ package Canine;
+ package Dog;
+ my Canine $spot : Watchful ;
+
+Effect:
+
+ use attributes ();
+ attributes::->import(Canine => \$spot, "Watchful");
+
+=item 2.
+
+Code:
+
+ package Felis;
+ my $cat : Nervous;
+
+Effect:
+
+ use attributes ();
+ attributes::->import(Felis => \$cat, "Nervous");
+
+=item 3.
+
+Code:
+
+ package X;
+ sub foo : lvalue ;
+
+Effect:
+
+ use attributes X => \&foo, "lvalue";
+
+=item 4.
+
+Code:
+
+ package X;
+ sub Y::x : lvalue { 1 }
+
+Effect:
+
+ use attributes Y => \&Y::x, "lvalue";
+
+=item 5.
+
+Code:
+
+ package X;
+ sub foo { 1 }
+
+ package Y;
+ BEGIN { *bar = \&X::foo; }
+
+ package Z;
+ sub Y::bar : lvalue ;
+
+Effect:
+
+ use attributes X => \&X::foo, "lvalue";
+
+=back
+
+This last example is purely for purposes of completeness. You should not
+be trying to mess with the attributes of something in a package that's
+not your own.
+
+=head1 MORE EXAMPLES
+
+=over 4
+
+=item 1.
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class,$code,@attrs) = @_;
+
+ my $allowed = 'MyAttribute';
+ my @bad = grep { $_ ne $allowed } @attrs;
+
+ return @bad;
+ }
+
+ sub foo : MyAttribute {
+ print "foo\n";
+ }
+
+This example runs. At compile time C<MODIFY_CODE_ATTRIBUTES> is called. In that
+subroutine, we check if any attribute is disallowed and we return a list of
+these "bad attributes".
+
+As we return an empty list, everything is fine.
+
+=item 2.
+
+ sub MODIFY_CODE_ATTRIBUTES {
+ my ($class,$code,@attrs) = @_;
+
+ my $allowed = 'MyAttribute';
+ my @bad = grep{ $_ ne $allowed }@attrs;
+
+ return @bad;
+ }
+
+ sub foo : MyAttribute Test {
+ print "foo\n";
+ }
+
+This example is aborted at compile time as we use the attribute "Test" which
+isn't allowed. C<MODIFY_CODE_ATTRIBUTES> returns a list that contains a single
+element ('Test').
+
+=back
+
+=head1 SEE ALSO
+
+L<perlsub/"Private Variables via my()"> and
+L<perlsub/"Subroutine Attributes"> for details on the basic declarations;
+L<perlfunc/use> for details on the normal invocation mechanism.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/autodie.pm b/Master/tlpkg/tlperl/lib/autodie.pm
new file mode 100644
index 00000000000..8e8e7094c7c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autodie.pm
@@ -0,0 +1,424 @@
+package autodie;
+use 5.008;
+use strict;
+use warnings;
+
+use Fatal ();
+our @ISA = qw(Fatal);
+our $VERSION;
+
+BEGIN {
+ $VERSION = '2.06_01';
+}
+
+use constant ERROR_WRONG_FATAL => q{
+Incorrect version of Fatal.pm loaded by autodie.
+
+The autodie pragma uses an updated version of Fatal to do its
+heavy lifting. We seem to have loaded Fatal version %s, which is
+probably the version that came with your version of Perl. However
+autodie needs version %s, which would have come bundled with
+autodie.
+
+You may be able to solve this problem by adding the following
+line of code to your main program, before any use of Fatal or
+autodie.
+
+ use lib "%s";
+
+};
+
+# We have to check we've got the right version of Fatal before we
+# try to compile the rest of our code, lest we use a constant
+# that doesn't exist.
+
+BEGIN {
+
+ # If we have the wrong Fatal, then we've probably loaded the system
+ # one, not our own. Complain, and give a useful hint. ;)
+
+ if ($Fatal::VERSION ne $VERSION) {
+ my $autodie_path = $INC{'autodie.pm'};
+
+ $autodie_path =~ s/autodie\.pm//;
+
+ require Carp;
+
+ Carp::croak sprintf(
+ ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path
+ );
+ }
+}
+
+# When passing args to Fatal we want to keep the first arg
+# (our package) in place. Hence the splice.
+
+sub import {
+ splice(@_,1,0,Fatal::LEXICAL_TAG);
+ goto &Fatal::import;
+}
+
+sub unimport {
+ splice(@_,1,0,Fatal::LEXICAL_TAG);
+ goto &Fatal::unimport;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autodie - Replace functions with ones that succeed or die with lexical scope
+
+=head1 SYNOPSIS
+
+ use autodie; # Recommended: implies 'use autodie qw(:default)'
+
+ use autodie qw(:all); # Recommended more: defaults and system/exec.
+
+ use autodie qw(open close); # open/close succeed or die
+
+ open(my $fh, "<", $filename); # No need to check!
+
+ {
+ no autodie qw(open); # open failures won't die
+ open(my $fh, "<", $filename); # Could fail silently!
+ no autodie; # disable all autodies
+ }
+
+=head1 DESCRIPTION
+
+ bIlujDI' yIchegh()Qo'; yIHegh()!
+
+ It is better to die() than to return() in failure.
+
+ -- Klingon programming proverb.
+
+The C<autodie> pragma provides a convenient way to replace functions
+that normally return false on failure with equivalents that throw
+an exception on failure.
+
+The C<autodie> pragma has I<lexical scope>, meaning that functions
+and subroutines altered with C<autodie> will only change their behaviour
+until the end of the enclosing block, file, or C<eval>.
+
+If C<system> is specified as an argument to C<autodie>, then it
+uses L<IPC::System::Simple> to do the heavy lifting. See the
+description of that module for more information.
+
+=head1 EXCEPTIONS
+
+Exceptions produced by the C<autodie> pragma are members of the
+L<autodie::exception> class. The preferred way to work with
+these exceptions under Perl 5.10 is as follows:
+
+ use feature qw(switch);
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', $some_file);
+
+ my @records = <$fh>;
+
+ # Do things with @records...
+
+ close($fh);
+
+ };
+
+ given ($@) {
+ when (undef) { say "No error"; }
+ when ('open') { say "Error from open"; }
+ when (':io') { say "Non-open, IO error."; }
+ when (':all') { say "All other autodie errors." }
+ default { say "Not an autodie error at all." }
+ }
+
+Under Perl 5.8, the C<given/when> structure is not available, so the
+following structure may be used:
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', $some_file);
+
+ my @records = <$fh>;
+
+ # Do things with @records...
+
+ close($fh);
+ };
+
+ if ($@ and $@->isa('autodie::exception')) {
+ if ($@->matches('open')) { print "Error from open\n"; }
+ if ($@->matches(':io' )) { print "Non-open, IO error."; }
+ } elsif ($@) {
+ # A non-autodie exception.
+ }
+
+See L<autodie::exception> for further information on interrogating
+exceptions.
+
+=head1 CATEGORIES
+
+Autodie uses a simple set of categories to group together similar
+built-ins. Requesting a category type (starting with a colon) will
+enable autodie for all built-ins beneath that category. For example,
+requesting C<:file> will enable autodie for C<close>, C<fcntl>,
+C<fileno>, C<open> and C<sysopen>.
+
+The categories are currently:
+
+ :all
+ :default
+ :io
+ read
+ seek
+ sysread
+ sysseek
+ syswrite
+ :dbm
+ dbmclose
+ dbmopen
+ :file
+ binmode
+ close
+ fcntl
+ fileno
+ flock
+ ioctl
+ open
+ sysopen
+ truncate
+ :filesys
+ chdir
+ closedir
+ opendir
+ link
+ mkdir
+ readlink
+ rename
+ rmdir
+ symlink
+ unlink
+ :ipc
+ pipe
+ :msg
+ msgctl
+ msgget
+ msgrcv
+ msgsnd
+ :semaphore
+ semctl
+ semget
+ semop
+ :shm
+ shmctl
+ shmget
+ shmread
+ :socket
+ accept
+ bind
+ connect
+ getsockopt
+ listen
+ recv
+ send
+ setsockopt
+ shutdown
+ socketpair
+ :threads
+ fork
+ :system
+ system
+ exec
+
+
+Note that while the above category system is presently a strict
+hierarchy, this should not be assumed.
+
+A plain C<use autodie> implies C<use autodie qw(:default)>. Note that
+C<system> and C<exec> are not enabled by default. C<system> requires
+the optional L<IPC::System::Simple> module to be installed, and enabling
+C<system> or C<exec> will invalidate their exotic forms. See L</BUGS>
+below for more details.
+
+The syntax:
+
+ use autodie qw(:1.994);
+
+allows the C<:default> list from a particular version to be used. This
+provides the convenience of using the default methods, but the surety
+that no behavorial changes will occur if the C<autodie> module is
+upgraded.
+
+C<autodie> can be enabled for all of Perl's built-ins, including
+C<system> and C<exec> with:
+
+ use autodie qw(:all);
+
+=head1 FUNCTION SPECIFIC NOTES
+
+=head2 flock
+
+It is not considered an error for C<flock> to return false if it fails
+to an C<EWOULDBLOCK> (or equivalent) condition. This means one can
+still use the common convention of testing the return value of
+C<flock> when called with the C<LOCK_NB> option:
+
+ use autodie;
+
+ if ( flock($fh, LOCK_EX | LOCK_NB) ) {
+ # We have a lock
+ }
+
+Autodying C<flock> will generate an exception if C<flock> returns
+false with any other error.
+
+=head2 system/exec
+
+The C<system> built-in is considered to have failed in the following
+circumstances:
+
+=over 4
+
+=item *
+
+The command does not start.
+
+=item *
+
+The command is killed by a signal.
+
+=item *
+
+The command returns a non-zero exit value (but see below).
+
+=back
+
+On success, the autodying form of C<system> returns the I<exit value>
+rather than the contents of C<$?>.
+
+Additional allowable exit values can be supplied as an optional first
+argument to autodying C<system>:
+
+ system( [ 0, 1, 2 ], $cmd, @args); # 0,1,2 are good exit values
+
+C<autodie> uses the L<IPC::System::Simple> module to change C<system>.
+See its documentation for further information.
+
+Applying C<autodie> to C<system> or C<exec> causes the exotic
+forms C<system { $cmd } @args > or C<exec { $cmd } @args>
+to be considered a syntax error until the end of the lexical scope.
+If you really need to use the exotic form, you can call C<CORE::system>
+or C<CORE::exec> instead, or use C<no autodie qw(system exec)> before
+calling the exotic form.
+
+=head1 GOTCHAS
+
+Functions called in list context are assumed to have failed if they
+return an empty list, or a list consisting only of a single undef
+element.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item :void cannot be used with lexical scope
+
+The C<:void> option is supported in L<Fatal>, but not
+C<autodie>. To workaround this, C<autodie> may be explicitly disabled until
+the end of the current block with C<no autodie>.
+To disable autodie for only a single function (eg, open)
+use C<no autodie qw(open)>.
+
+=item No user hints defined for %s
+
+You've insisted on hints for user-subroutines, either by pre-pending
+a C<!> to the subroutine name itself, or earlier in the list of arguments
+to C<autodie>. However the subroutine in question does not have
+any hints available.
+
+=back
+
+See also L<Fatal/DIAGNOSTICS>.
+
+=head1 BUGS
+
+"Used only once" warnings can be generated when C<autodie> or C<Fatal>
+is used with package filehandles (eg, C<FILE>). Scalar filehandles are
+strongly recommended instead.
+
+When using C<autodie> or C<Fatal> with user subroutines, the
+declaration of those subroutines must appear before the first use of
+C<Fatal> or C<autodie>, or have been exported from a module.
+Attempting to use C<Fatal> or C<autodie> on other user subroutines will
+result in a compile-time error.
+
+Due to a bug in Perl, C<autodie> may "lose" any format which has the
+same name as an autodying built-in or function.
+
+C<autodie> may not work correctly if used inside a file with a
+name that looks like a string eval, such as F<eval (3)>.
+
+=head2 autodie and string eval
+
+Due to the current implementation of C<autodie>, unexpected results
+may be seen when used near or with the string version of eval.
+I<None of these bugs exist when using block eval>.
+
+Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval>
+statements, although it can be explicitly enabled inside a string
+C<eval>.
+
+Under Perl 5.10 only, using a string eval when C<autodie> is in
+effect can cause the autodie behaviour to leak into the surrounding
+scope. This can be worked around by using a C<no autodie> at the
+end of the scope to explicitly remove autodie's effects, or by
+avoiding the use of string eval.
+
+I<None of these bugs exist when using block eval>. The use of
+C<autodie> with block eval is considered good practice.
+
+=head2 REPORTING BUGS
+
+Please report bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie>.
+
+=head1 FEEDBACK
+
+If you find this module useful, please consider rating it on the
+CPAN Ratings service at
+L<http://cpanratings.perl.org/rate?distribution=autodie> .
+
+The module author loves to hear how C<autodie> has made your life
+better (or worse). Feedback can be sent to
+E<lt>pjf@perltraining.com.auE<gt>.
+
+=head1 AUTHOR
+
+Copyright 2008-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<Fatal>, L<autodie::exception>, L<autodie::hints>, L<IPC::System::Simple>
+
+I<Perl tips, autodie> at
+L<http://perltraining.com.au/tips/2008-08-20.html>
+
+=head1 ACKNOWLEDGEMENTS
+
+Mark Reed and Roland Giersig -- Klingon translators.
+
+See the F<AUTHORS> file for full credits. The latest version of this
+file can be found at
+L<http://github.com/pfenwick/autodie/tree/master/AUTHORS> .
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/autouse.pm b/Master/tlpkg/tlperl/lib/autouse.pm
new file mode 100644
index 00000000000..cbde3864bf1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/autouse.pm
@@ -0,0 +1,171 @@
+package autouse;
+
+#use strict; # debugging only
+use 5.006; # use warnings
+
+$autouse::VERSION = '1.06';
+
+$autouse::DEBUG ||= 0;
+
+sub vet_import ($);
+
+sub croak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+sub import {
+ my $class = @_ ? shift : 'autouse';
+ croak "usage: use $class MODULE [,SUBS...]" unless @_;
+ my $module = shift;
+
+ (my $pm = $module) =~ s{::}{/}g;
+ $pm .= '.pm';
+ if (exists $INC{$pm}) {
+ vet_import $module;
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+ # $Exporter::Verbose = 1;
+ return $module->import(map { (my $f = $_) =~ s/\(.*?\)$//; $f } @_);
+ }
+
+ # It is not loaded: need to do real work.
+ my $callpkg = caller(0);
+ print "autouse called from $callpkg\n" if $autouse::DEBUG;
+
+ my $index;
+ for my $f (@_) {
+ my $proto;
+ $proto = $1 if (my $func = $f) =~ s/\((.*)\)$//;
+
+ my $closure_import_func = $func; # Full name
+ my $closure_func = $func; # Name inside package
+ my $index = rindex($func, '::');
+ if ($index == -1) {
+ $closure_import_func = "${callpkg}::$func";
+ } else {
+ $closure_func = substr $func, $index + 2;
+ croak "autouse into different package attempted"
+ unless substr($func, 0, $index) eq $module;
+ }
+
+ my $load_sub = sub {
+ unless ($INC{$pm}) {
+ require $pm;
+ vet_import $module;
+ }
+ no warnings qw(redefine prototype);
+ *$closure_import_func = \&{"${module}::$closure_func"};
+ print "autousing $module; "
+ ."imported $closure_func as $closure_import_func\n"
+ if $autouse::DEBUG;
+ goto &$closure_import_func;
+ };
+
+ if (defined $proto) {
+ *$closure_import_func = eval "sub ($proto) { goto &\$load_sub }"
+ || die;
+ } else {
+ *$closure_import_func = $load_sub;
+ }
+ }
+}
+
+sub vet_import ($) {
+ my $module = shift;
+ if (my $import = $module->can('import')) {
+ croak "autoused module $module has unique import() method"
+ unless defined(&Exporter::import)
+ && ($import == \&Exporter::import ||
+ $import == \&UNIVERSAL::import)
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autouse - postpone load of modules until a function is used
+
+=head1 SYNOPSIS
+
+ use autouse 'Carp' => qw(carp croak);
+ carp "this carp was predeclared and autoused ";
+
+=head1 DESCRIPTION
+
+If the module C<Module> is already loaded, then the declaration
+
+ use autouse 'Module' => qw(func1 func2($;$));
+
+is equivalent to
+
+ use Module qw(func1 func2);
+
+if C<Module> defines func2() with prototype C<($;$)>, and func1() has
+no prototypes. (At least if C<Module> uses C<Exporter>'s C<import>,
+otherwise it is a fatal error.)
+
+If the module C<Module> is not loaded yet, then the above declaration
+declares functions func1() and func2() in the current package. When
+these functions are called, they load the package C<Module> if needed,
+and substitute themselves with the correct definitions.
+
+=begin _deprecated
+
+ use Module qw(Module::func3);
+
+will work and is the equivalent to:
+
+ use Module qw(func3);
+
+It is not a very useful feature and has been deprecated.
+
+=end _deprecated
+
+
+=head1 WARNING
+
+Using C<autouse> will move important steps of your program's execution
+from compile time to runtime. This can
+
+=over 4
+
+=item *
+
+Break the execution of your program if the module you C<autouse>d has
+some initialization which it expects to be done early.
+
+=item *
+
+hide bugs in your code since important checks (like correctness of
+prototypes) is moved from compile time to runtime. In particular, if
+the prototype you specified on C<autouse> line is wrong, you will not
+find it out until the corresponding function is executed. This will be
+very unfortunate for functions which are not always called (note that
+for such functions C<autouse>ing gives biggest win, for a workaround
+see below).
+
+=back
+
+To alleviate the second problem (partially) it is advised to write
+your scripts like this:
+
+ use Module;
+ use autouse Module => qw(carp($) croak(&$));
+ carp "this carp was predeclared and autoused ";
+
+The first line ensures that the errors in your argument specification
+are found early. When you ship your application you should comment
+out the first line, since it makes the second one useless.
+
+=head1 AUTHOR
+
+Ilya Zakharevich (ilya@math.ohio-state.edu)
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/base.pm b/Master/tlpkg/tlperl/lib/base.pm
new file mode 100644
index 00000000000..2f6a19e4b9a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/base.pm
@@ -0,0 +1,265 @@
+package base;
+
+use strict 'vars';
+use vars qw($VERSION);
+$VERSION = '2.15';
+$VERSION = eval $VERSION;
+
+# constant.pm is slow
+sub SUCCESS () { 1 }
+
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+my $Fattr = \%fields::attr;
+
+sub has_fields {
+ my($base) = shift;
+ my $fglob = ${"$base\::"}{FIELDS};
+ return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
+}
+
+sub has_version {
+ my($base) = shift;
+ my $vglob = ${$base.'::'}{VERSION};
+ return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
+}
+
+sub has_attr {
+ my($proto) = shift;
+ my($class) = ref $proto || $proto;
+ return exists $Fattr->{$class};
+}
+
+sub get_attr {
+ $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
+ return $Fattr->{$_[0]};
+}
+
+if ($] < 5.009) {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ my $f = \%{$_[0].'::FIELDS'};
+
+ # should be centralized in fields? perhaps
+ # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
+ # is used here anyway, it doesn't matter.
+ bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
+
+ return $f;
+ }
+}
+else {
+ *get_fields = sub {
+ # Shut up a possible typo warning.
+ () = \%{$_[0].'::FIELDS'};
+ return \%{$_[0].'::FIELDS'};
+ }
+}
+
+sub import {
+ my $class = shift;
+
+ return SUCCESS unless @_;
+
+ # List of base classes from which we will inherit %FIELDS.
+ my $fields_base;
+
+ my $inheritor = caller(0);
+ my @isa_classes;
+
+ my @bases;
+ foreach my $base (@_) {
+ if ( $inheritor eq $base ) {
+ warn "Class '$inheritor' tried to inherit from itself\n";
+ }
+
+ next if grep $_->isa($base), ($inheritor, @bases);
+
+ if (has_version($base)) {
+ ${$base.'::VERSION'} = '-1, set by base.pm'
+ unless defined ${$base.'::VERSION'};
+ }
+ else {
+ my $sigdie;
+ {
+ local $SIG{__DIE__};
+ eval "require $base";
+ # Only ignore "Can't locate" errors from our eval require.
+ # Other fatal errors (syntax etc) must be reported.
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ unless (%{"$base\::"}) {
+ require Carp;
+ local $" = " ";
+ Carp::croak(<<ERROR);
+Base class package "$base" is empty.
+ (Perhaps you need to 'use' the module which defines that package first,
+ or make that module available in \@INC (\@INC contains: @INC).
+ERROR
+ }
+ $sigdie = $SIG{__DIE__} || undef;
+ }
+ # Make sure a global $SIG{__DIE__} makes it out of the localization.
+ $SIG{__DIE__} = $sigdie if defined $sigdie;
+ ${$base.'::VERSION'} = "-1, set by base.pm"
+ unless defined ${$base.'::VERSION'};
+ }
+ push @bases, $base;
+
+ if ( has_fields($base) || has_attr($base) ) {
+ # No multiple fields inheritance *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit fields");
+ } else {
+ $fields_base = $base;
+ }
+ }
+ }
+ # Save this until the end so it's all or nothing if the above loop croaks.
+ push @{"$inheritor\::ISA"}, @isa_classes;
+
+ push @{"$inheritor\::ISA"}, @bases;
+
+ if( defined $fields_base ) {
+ inherit_fields($inheritor, $fields_base);
+ }
+}
+
+
+sub inherit_fields {
+ my($derived, $base) = @_;
+
+ return SUCCESS unless $base;
+
+ my $battr = get_attr($base);
+ my $dattr = get_attr($derived);
+ my $dfields = get_fields($derived);
+ my $bfields = get_fields($base);
+
+ $dattr->[0] = @$battr;
+
+ if( keys %$dfields ) {
+ warn <<"END";
+$derived is inheriting from $base but already has its own fields!
+This will cause problems. Be sure you use base BEFORE declaring fields.
+END
+
+ }
+
+ # Iterate through the base's fields adding all the non-private
+ # ones to the derived class. Hang on to the original attribute
+ # (Public, Private, etc...) and add Inherited.
+ # This is all too complicated to do efficiently with add_fields().
+ while (my($k,$v) = each %$bfields) {
+ my $fno;
+ if ($fno = $dfields->{$k} and $fno != $v) {
+ require Carp;
+ Carp::croak ("Inherited fields can't override existing fields");
+ }
+
+ if( $battr->[$v] & PRIVATE ) {
+ $dattr->[$v] = PRIVATE | INHERITED;
+ }
+ else {
+ $dattr->[$v] = INHERITED | $battr->[$v];
+ $dfields->{$k} = $v;
+ }
+ }
+
+ foreach my $idx (1..$#{$battr}) {
+ next if defined $dattr->[$idx];
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+base - Establish an ISA relationship with base classes at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use base qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Unless you are using the C<fields> pragma, consider this module discouraged
+in favor of the lighter-weight C<parent>.
+
+Allows you to both load one or more modules, while setting up inheritance from
+those modules at the same time. Roughly similar in effect to
+
+ package Baz;
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+C<base> employs some heuristics to determine if a module has already been
+loaded, if it has it doesn't try again. If C<base> tries to C<require> the
+module it will not die if it cannot find the module's file, but will die on any
+other error. After all this, should your base class be empty, containing no
+symbols, it will die. This is useful for inheriting from classes in the same
+file as yourself, like so:
+
+ package Foo;
+ sub exclaim { "I can have such a thing?!" }
+
+ package Bar;
+ use base "Foo";
+
+If $VERSION is not detected even after loading it, <base> will define $VERSION
+in the base package, setting it to the string C<-1, set by base.pm>.
+
+C<base> will also initialize the fields if one of the base classes has it.
+Multiple inheritance of fields is B<NOT> supported, if two or more base classes
+each have inheritable fields the 'base' pragma will croak. See L<fields>,
+L<public> and L<protected> for a description of this feature.
+
+The base class' C<import> method is B<not> called.
+
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Base class package "%s" is empty.
+
+base.pm was unable to require the base package, because it was not
+found in your path.
+
+=item Class 'Foo' tried to inherit from itself
+
+Attempting to inherit from yourself generates a warning.
+
+ use Foo;
+ use base 'Foo';
+
+=back
+
+=head1 HISTORY
+
+This module was introduced with Perl 5.004_04.
+
+=head1 CAVEATS
+
+Due to the limitations of the implementation, you must use
+base I<before> you declare any of your own fields.
+
+
+=head1 SEE ALSO
+
+L<fields>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/bigfloat.pl b/Master/tlpkg/tlperl/lib/bigfloat.pl
new file mode 100644
index 00000000000..dd0bc05af2f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bigfloat.pl
@@ -0,0 +1,256 @@
+package bigfloat;
+require "bigint.pl";
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Math::BigFloat
+
+# Arbitrary length float math package
+#
+# by Mark Biggar
+#
+# number format
+# canonical strings have the form /[+-]\d+E[+-]\d+/
+# Input values can have embedded whitespace
+# Error returns
+# 'NaN' An input parameter was "Not a Number" or
+# divide by zero or sqrt of negative number
+# Division is computed to
+# max($div_scale,length(dividend)+length(divisor))
+# digits by default.
+# Also used for default sqrt scale
+
+$div_scale = 40;
+
+# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+$rnd_mode = 'even';
+
+# bigfloat routines
+#
+# fadd(NSTR, NSTR) return NSTR addition
+# fsub(NSTR, NSTR) return NSTR subtraction
+# fmul(NSTR, NSTR) return NSTR multiplication
+# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
+# fneg(NSTR) return NSTR negation
+# fabs(NSTR) return NSTR absolute value
+# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
+# fround(NSTR, SCALE) return NSTR round to SCALE digits
+# ffround(NSTR, SCALE) return NSTR round at SCALEth place
+# fnorm(NSTR) return (NSTR) normalize
+# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
+
+# Convert a number to canonical string form.
+# Takes something that looks like a number and converts it to
+# the form /^[+-]\d+E[+-]\d+$/.
+sub main'fnorm { #(string) return fnum_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/
+ && ($2 ne '' || defined($4))) {
+ my $x = defined($4) ? $4 : '';
+ &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6));
+ } else {
+ 'NaN';
+ }
+}
+
+# normalize number -- for internal use
+sub norm { #(mantissa, exponent) return fnum_str
+ local($_, $exp) = @_;
+ if ($_ eq 'NaN') {
+ 'NaN';
+ } else {
+ s/^([+-])0+/$1/; # strip leading zeros
+ if (length($_) == 1) {
+ '+0E+0';
+ } else {
+ $exp += length($1) if (s/(0+)$//); # strip trailing zeros
+ sprintf("%sE%+ld", $_, $exp);
+ }
+ }
+}
+
+# negation
+sub main'fneg { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[$[]);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
+ if ( ord("\t") == 9 ) { # ascii
+ s/^H/N/;
+ }
+ else { # ebcdic character set
+ s/\373/N/;
+ }
+ $_;
+}
+
+# absolute value
+sub main'fabs { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[$[]);
+ s/^-/+/; # mash sign
+ $_;
+}
+
+# multiplication
+sub main'fmul { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ &norm(&'bmul($xm,$ym),$xe+$ye);
+ }
+}
+
+# addition
+sub main'fadd { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+ }
+}
+
+# subtraction
+sub main'fsub { #(fnum_str, fnum_str) return fnum_str
+ &'fadd($_[$[],&'fneg($_[$[+1]));
+}
+
+# division
+# args are dividend, divisor, scale (optional)
+# result has at most max(scale, length(dividend), length(divisor)) digits
+sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+{
+ local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]);
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if (length($xm)-1 > $scale);
+ $scale = length($ym)-1 if (length($ym)-1 > $scale);
+ $scale = $scale + length($ym) - length($xm);
+ &norm(&round(&'bdiv($xm.('0' x $scale),$ym),&'babs($ym)),
+ $xe-$ye-$scale);
+ }
+}
+
+# round int $q based on fraction $r/$base using $rnd_mode
+sub round { #(int_str, int_str, int_str) return int_str
+ local($q,$r,$base) = @_;
+ if ($q eq 'NaN' || $r eq 'NaN') {
+ 'NaN';
+ } elsif ($rnd_mode eq 'trunc') {
+ $q; # just truncate
+ } else {
+ local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
+ if ( $cmp < 0 ||
+ ($cmp == 0 &&
+ ( $rnd_mode eq 'zero' ||
+ ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
+ ($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
+ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
+ $q; # round down
+ } else {
+ &'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
+ # round up
+ }
+ }
+}
+
+# round the mantissa of $x to $scale digits
+sub main'fround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
+ if ($x eq 'NaN' || $scale <= 0) {
+ $x;
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if (length($xm)-1 <= $scale) {
+ $x;
+ } else {
+ &norm(&round(substr($xm,$[,$scale+1),
+ "+0".substr($xm,$[+$scale+1,1),"+10"),
+ $xe+length($xm)-$scale-1);
+ }
+ }
+}
+
+# round $x at the 10 to the $scale digit place
+sub main'ffround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if ($xe >= $scale) {
+ $x;
+ } else {
+ $xe = length($xm)+$xe-$scale;
+ if ($xe < 1) {
+ '+0E+0';
+ } elsif ($xe == 1) {
+ # The first substr preserves the sign, which means that
+ # we'll pass a non-normalized "-0" to &round when rounding
+ # -0.006 (for example), purely so that &round won't lose
+ # the sign.
+ &norm(&round(substr($xm,$[,1).'0',
+ "+0".substr($xm,$[+1,1),"+10"), $scale);
+ } else {
+ &norm(&round(substr($xm,$[,$xe),
+ "+0".substr($xm,$[+$xe,1),"+10"), $scale);
+ }
+ }
+ }
+}
+
+# compare 2 values returns one of undef, <0, =0, >0
+# returns undef if either or both input value are not numbers
+sub main'fcmp #(fnum_str, fnum_str) return cond_code
+{
+ local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
+ if ($x eq "NaN" || $y eq "NaN") {
+ undef;
+ } else {
+ ord($y) <=> ord($x)
+ ||
+ ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
+ (($xe <=> $ye) * (substr($x,$[,1).'1')
+ || &bigint'cmp($xm,$ym))
+ );
+ }
+}
+
+# square root by Newtons method.
+sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
+ local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]);
+ if ($x eq 'NaN' || $x =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0E+0') {
+ '+0E+0';
+ } else {
+ local($xm, $xe) = split('E',$x);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if ($scale < length($xm)-1);
+ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ while ($gs < 2*$scale) {
+ $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
+ $gs *= 2;
+ }
+ &'fround($guess, $scale);
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/bigint.pl b/Master/tlpkg/tlperl/lib/bigint.pl
new file mode 100644
index 00000000000..d28f0e27a0b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bigint.pl
@@ -0,0 +1,322 @@
+package bigint;
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# Suggested alternative: Math::BigInt
+
+# arbitrary size integer math package
+#
+# by Mark Biggar
+#
+# Canonical Big integer value are strings of the form
+# /^[+-]\d+$/ with leading zeros suppressed
+# Input values to these routines may be strings of the form
+# /^\s*[+-]?[\d\s]+$/.
+# Examples:
+# '+0' canonical zero value
+# ' -123 123 123' canonical value '-123123123'
+# '1 23 456 7890' canonical value '+1234567890'
+# Output values always in canonical form
+#
+# Actual math is done in an internal format consisting of an array
+# whose first element is the sign (/^[+-]$/) and whose remaining
+# elements are base 100000 digits with the least significant digit first.
+# The string 'NaN' is used to represent the result when input arguments
+# are not numbers, as well as the result of dividing by zero
+#
+# routines provided are:
+#
+# bneg(BINT) return BINT negation
+# babs(BINT) return BINT absolute value
+# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0)
+# badd(BINT,BINT) return BINT addition
+# bsub(BINT,BINT) return BINT subtraction
+# bmul(BINT,BINT) return BINT multiplication
+# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
+# bmod(BINT,BINT) return BINT modulus
+# bgcd(BINT,BINT) return BINT greatest common divisor
+# bnorm(BINT) return BINT normalization
+#
+
+# overcome a floating point problem on certain osnames (posix-bc, os390)
+BEGIN {
+ my $x = 100000.0;
+ my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0;
+}
+
+$zero = 0;
+
+
+# normalize string form of number. Strip leading zeros. Strip any
+# white space and add a sign, if missing.
+# Strings that are not numbers result the value 'NaN'.
+
+sub main'bnorm { #(num_str) return num_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
+ substr($_,$[,0) = '+' unless $1; # Add missing sign
+ s/^-0/+0/;
+ $_;
+ } else {
+ 'NaN';
+ }
+}
+
+# Convert a number from string format to internal base 100000 format.
+# Assumes normalized value as input.
+sub internal { #(num_str) return int_num_array
+ local($d) = @_;
+ ($is,$il) = (substr($d,$[,1),length($d)-2);
+ substr($d,$[,1) = '';
+ ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
+}
+
+# Convert a number from internal base 100000 format to string format.
+# This routine scribbles all over input array.
+sub external { #(int_num_array) return num_str
+ $es = shift;
+ grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
+ &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
+}
+
+# Negate input value.
+sub main'bneg { #(num_str) return num_str
+ local($_) = &'bnorm(@_);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
+ s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC
+ $_;
+}
+
+# Returns the absolute value of the input.
+sub main'babs { #(num_str) return num_str
+ &abs(&'bnorm(@_));
+}
+
+sub abs { # post-normalized abs for internal use
+ local($_) = @_;
+ s/^-/+/;
+ $_;
+}
+
+# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+sub main'bcmp { #(num_str, num_str) return cond_code
+ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ undef;
+ } elsif ($y eq 'NaN') {
+ undef;
+ } else {
+ &cmp($x,$y);
+ }
+}
+
+sub cmp { # post-normalized compare for internal use
+ local($cx, $cy) = @_;
+ return 0 if ($cx eq $cy);
+
+ local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1));
+ local($ld);
+
+ if ($sx eq '+') {
+ return 1 if ($sy eq '-' || $cy eq '+0');
+ $ld = length($cx) - length($cy);
+ return $ld if ($ld);
+ return $cx cmp $cy;
+ } else { # $sx eq '-'
+ return -1 if ($sy eq '+');
+ $ld = length($cy) - length($cx);
+ return $ld if ($ld);
+ return $cy cmp $cx;
+ }
+
+}
+
+sub main'badd { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x); # convert to internal form
+ @y = &internal($y);
+ local($sx, $sy) = (shift @x, shift @y); # get signs
+ if ($sx eq $sy) {
+ &external($sx, &add(*x, *y)); # if same sign add
+ } else {
+ ($x, $y) = (&abs($x),&abs($y)); # make abs
+ if (&cmp($y,$x) > 0) {
+ &external($sy, &sub(*y, *x));
+ } else {
+ &external($sx, &sub(*x, *y));
+ }
+ }
+ }
+}
+
+sub main'bsub { #(num_str, num_str) return num_str
+ &'badd($_[$[],&'bneg($_[$[+1]));
+}
+
+# GCD -- Euclids algorithm Knuth Vol 2 pg 296
+sub main'bgcd { #(num_str, num_str) return num_str
+ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
+ $x;
+ }
+}
+
+# routine to add two base 1e5 numbers
+# stolen from Knuth Vol 2 Algorithm A pg 231
+# there are separate routines to add and sub as per Kunth pg 233
+sub add { #(int_num_array, int_num_array) return int_num_array
+ local(*x, *y) = @_;
+ $car = 0;
+ for $x (@x) {
+ last unless @y || $car;
+ $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0;
+ }
+ for $y (@y) {
+ last unless $car;
+ $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
+ }
+ (@x, @y, $car);
+}
+
+# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+sub sub { #(int_num_array, int_num_array) return int_num_array
+ local(*sx, *sy) = @_;
+ $bar = 0;
+ for $sx (@sx) {
+ last unless @y || $bar;
+ $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0);
+ }
+ @sx;
+}
+
+# multiply two numbers -- stolen from Knuth Vol 2 pg 233
+sub main'bmul { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x);
+ @y = &internal($y);
+ local($signr) = (shift @x ne shift @y) ? '-' : '+';
+ @prod = ();
+ for $x (@x) {
+ ($car, $cty) = (0, $[);
+ for $y (@y) {
+ $prod = $x * $y + $prod[$cty] + $car;
+ if ($use_mult) {
+ $prod[$cty++] =
+ $prod - ($car = int($prod * 1e-5)) * 1e5;
+ }
+ else {
+ $prod[$cty++] =
+ $prod - ($car = int($prod / 1e5)) * 1e5;
+ }
+ }
+ $prod[$cty] += $car if $car;
+ $x = shift @prod;
+ }
+ &external($signr, @x, @prod);
+ }
+}
+
+# modulus
+sub main'bmod { #(num_str, num_str) return num_str
+ (&'bdiv(@_))[$[+1];
+}
+
+sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
+ local (*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
+ return wantarray ? ('NaN','NaN') : 'NaN'
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
+ return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
+ @x = &internal($x); @y = &internal($y);
+ $srem = $y[$[];
+ $sr = (shift @x ne shift @y) ? '-' : '+';
+ $car = $bar = $prd = 0;
+ if (($dd = int(1e5/($y[$#y]+1))) != 1) {
+ for $x (@x) {
+ $x = $x * $dd + $car;
+ if ($use_mult) {
+ $x -= ($car = int($x * 1e-5)) * 1e5;
+ }
+ else {
+ $x -= ($car = int($x / 1e5)) * 1e5;
+ }
+ }
+ push(@x, $car); $car = 0;
+ for $y (@y) {
+ $y = $y * $dd + $car;
+ if ($use_mult) {
+ $y -= ($car = int($y * 1e-5)) * 1e5;
+ }
+ else {
+ $y -= ($car = int($y / 1e5)) * 1e5;
+ }
+ }
+ }
+ else {
+ push(@x, 0);
+ }
+ @q = (); ($v2,$v1) = @y[-2,-1];
+ while ($#x > $#y) {
+ ($u2,$u1,$u0) = @x[-3..-1];
+ $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
+ if ($q) {
+ ($car, $bar) = (0,0);
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
+ $prd = $q * $y[$y] + $car;
+ if ($use_mult) {
+ $prd -= ($car = int($prd * 1e-5)) * 1e5;
+ }
+ else {
+ $prd -= ($car = int($prd / 1e5)) * 1e5;
+ }
+ $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
+ }
+ if ($x[$#x] < $car + $bar) {
+ $car = 0; --$q;
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
+ $x[$x] -= 1e5
+ if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
+ }
+ }
+ }
+ pop(@x); unshift(@q, $q);
+ }
+ if (wantarray) {
+ @d = ();
+ if ($dd != 1) {
+ $car = 0;
+ for $x (reverse @x) {
+ $prd = $car * 1e5 + $x;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else {
+ @d = @x;
+ }
+ (&external($sr, @q), &external($srem, @d, $zero));
+ } else {
+ &external($sr, @q);
+ }
+}
+1;
diff --git a/Master/tlpkg/tlperl/lib/bigint.pm b/Master/tlpkg/tlperl/lib/bigint.pm
new file mode 100644
index 00000000000..e143af61d0a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bigint.pm
@@ -0,0 +1,675 @@
+package bigint;
+use 5.006;
+
+$VERSION = '0.23';
+use Exporter;
+@ISA = qw( Exporter );
+@EXPORT_OK = qw( PI e bpi bexp );
+@EXPORT = qw( inf NaN );
+
+use strict;
+use overload;
+
+##############################################################################
+
+# These are all alike, and thus faked by AUTOLOAD
+
+my @faked = qw/round_mode accuracy precision div_scale/;
+use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
+
+sub AUTOLOAD
+ {
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ no strict 'refs';
+ foreach my $n (@faked)
+ {
+ if ($n eq $name)
+ {
+ *{"bigint::$name"} = sub
+ {
+ my $self = shift;
+ no strict 'refs';
+ if (defined $_[0])
+ {
+ return Math::BigInt->$name($_[0]);
+ }
+ return Math::BigInt->$name();
+ };
+ return &$name;
+ }
+ }
+
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call bigint\-\>$name, not a valid method");
+ }
+
+sub upgrade
+ {
+ $Math::BigInt::upgrade;
+ }
+
+sub _binary_constant
+ {
+ # this takes a binary/hexadecimal/octal constant string and returns it
+ # as string suitable for new. Basically it converts octal to decimal, and
+ # passes every thing else unmodified back.
+ my $string = shift;
+
+ return Math::BigInt->new($string) if $string =~ /^0[bx]/;
+
+ # so it must be an octal constant
+ Math::BigInt->from_oct($string);
+ }
+
+sub _float_constant
+ {
+ # this takes a floating point constant string and returns it truncated to
+ # integer. For instance, '4.5' => '4', '1.234e2' => '123' etc
+ my $float = shift;
+
+ # some simple cases first
+ return $float if ($float =~ /^[+-]?[0-9]+$/); # '+123','-1','0' etc
+ return $float
+ if ($float =~ /^[+-]?[0-9]+\.?[eE]\+?[0-9]+$/); # 123e2, 123.e+2
+ return '0' if ($float =~ /^[+-]?[0]*\.[0-9]+$/); # .2, 0.2, -.1
+ if ($float =~ /^[+-]?[0-9]+\.[0-9]*$/) # 1., 1.23, -1.2 etc
+ {
+ $float =~ s/\..*//;
+ return $float;
+ }
+ my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split($float);
+ return $float if !defined $mis; # doesn't look like a number to me
+ my $ec = int($$ev);
+ my $sign = $$mis; $sign = '' if $sign eq '+';
+ if ($$es eq '-')
+ {
+ # ignore fraction part entirely
+ if ($ec >= length($$miv)) # 123.23E-4
+ {
+ return '0';
+ }
+ return $sign . substr ($$miv,0,length($$miv)-$ec); # 1234.45E-2 = 12
+ }
+ # xE+y
+ if ($ec >= length($$mfv))
+ {
+ $ec -= length($$mfv);
+ return $sign.$$miv.$$mfv if $ec == 0; # 123.45E+2 => 12345
+ return $sign.$$miv.$$mfv.'E'.$ec; # 123.45e+3 => 12345e1
+ }
+ $mfv = substr($$mfv,0,$ec);
+ $sign.$$miv.$mfv; # 123.45e+1 => 1234
+ }
+
+sub unimport
+ {
+ $^H{bigint} = undef; # no longer in effect
+ overload::remove_constant('binary','','float','','integer');
+ }
+
+sub in_effect
+ {
+ my $level = shift || 0;
+ my $hinthash = (caller($level))[10];
+ $hinthash->{bigint};
+ }
+
+#############################################################################
+# the following two routines are for "use bigint qw/hex oct/;":
+
+sub _hex_global
+ {
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct_global
+ {
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+#############################################################################
+# the following two routines are for Perl 5.9.4 or later and are lexical
+
+sub _hex
+ {
+ return CORE::hex($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct
+ {
+ return CORE::oct($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ $^H{bigint} = 1; # we are in effect
+
+ my ($hex,$oct);
+ # for newer Perls always override hex() and oct() with a lexical version:
+ if ($] > 5.009004)
+ {
+ $oct = \&_oct;
+ $hex = \&_hex;
+ }
+ # some defaults
+ my $lib = ''; my $lib_kind = 'try';
+
+ my @import = ( ':constant' ); # drive it w/ constant
+ my @a = @_; my $l = scalar @_; my $j = 0;
+ my ($ver,$trace); # version? trace?
+ my ($a,$p); # accuracy, precision
+ for ( my $i = 0; $i < $l ; $i++,$j++ )
+ {
+ if ($_[$i] =~ /^(l|lib|try|only)$/)
+ {
+ # this causes a different low lib to take care...
+ $lib_kind = $1; $lib_kind = 'lib' if $lib_kind eq 'l';
+ $lib = $_[$i+1] || '';
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(a|accuracy)$/)
+ {
+ $a = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(p|precision)$/)
+ {
+ $p = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(v|version)$/)
+ {
+ $ver = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] =~ /^(t|trace)$/)
+ {
+ $trace = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] eq 'hex')
+ {
+ splice @a, $j, 1; $j --;
+ $hex = \&_hex_global;
+ }
+ elsif ($_[$i] eq 'oct')
+ {
+ splice @a, $j, 1; $j --;
+ $oct = \&_oct_global;
+ }
+ elsif ($_[$i] !~ /^(PI|e|bpi|bexp)\z/)
+ {
+ die ("unknown option $_[$i]");
+ }
+ }
+ my $class;
+ $_lite = 0; # using M::BI::L ?
+ if ($trace)
+ {
+ require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
+ }
+ else
+ {
+ # see if we can find Math::BigInt::Lite
+ if (!defined $a && !defined $p) # rounding won't work to well
+ {
+ eval 'require Math::BigInt::Lite;';
+ if ($@ eq '')
+ {
+ @import = ( ); # :constant in Lite, not MBI
+ Math::BigInt::Lite->import( ':constant' );
+ $_lite= 1; # signal okay
+ }
+ }
+ require Math::BigInt if $_lite == 0; # not already loaded?
+ $class = 'Math::BigInt'; # regardless of MBIL or not
+ }
+ push @import, $lib_kind => $lib if $lib ne '';
+ # Math::BigInt::Trace or plain Math::BigInt
+ $class->import(@import);
+
+ bigint->accuracy($a) if defined $a;
+ bigint->precision($p) if defined $p;
+ if ($ver)
+ {
+ print "bigint\t\t\t v$VERSION\n";
+ print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
+ print "Math::BigInt\t\t v$Math::BigInt::VERSION";
+ my $config = Math::BigInt->config();
+ print " lib => $config->{lib} v$config->{lib_version}\n";
+ exit;
+ }
+ # we take care of floating point constants, since BigFloat isn't available
+ # and BigInt doesn't like them:
+ overload::constant float => sub { Math::BigInt->new( _float_constant(shift) ); };
+ # Take care of octal/hexadecimal constants
+ overload::constant binary => sub { _binary_constant(shift) };
+
+ # if another big* was already loaded:
+ my ($package) = caller();
+
+ no strict 'refs';
+ if (!defined *{"${package}::inf"})
+ {
+ $self->export_to_level(1,$self,@a); # export inf and NaN, e and PI
+ }
+ {
+ no warnings 'redefine';
+ *CORE::GLOBAL::oct = $oct if $oct;
+ *CORE::GLOBAL::hex = $hex if $hex;
+ }
+ }
+
+sub inf () { Math::BigInt::binf(); }
+sub NaN () { Math::BigInt::bnan(); }
+
+sub PI () { Math::BigInt->new(3); }
+sub e () { Math::BigInt->new(2); }
+sub bpi ($) { Math::BigInt->new(3); }
+sub bexp ($$) { my $x = Math::BigInt->new($_[0]); $x->bexp($_[1]); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+bigint - Transparent BigInteger support for Perl
+
+=head1 SYNOPSIS
+
+ use bigint;
+
+ $x = 2 + 4.5,"\n"; # BigInt 6
+ print 2 ** 512,"\n"; # really is what you think it is
+ print inf + 42,"\n"; # inf
+ print NaN * 7,"\n"; # NaN
+ print hex("0x1234567890123490"),"\n"; # Perl v5.9.4 or later
+
+ {
+ no bigint;
+ print 2 ** 256,"\n"; # a normal Perl scalar now
+ }
+
+ # Note that this will be global:
+ use bigint qw/hex oct/;
+ print hex("0x1234567890123490"),"\n";
+ print oct("01234567890123490"),"\n";
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded. Integer
+constants are created as proper BigInts.
+
+Floating point constants are truncated to integer. All parts and results of
+expressions are also truncated.
+
+Unlike L<integer>, this pragma creates integer constants that are only
+limited in their size by the available memory and CPU time.
+
+=head2 use integer vs. use bigint
+
+There is one small difference between C<use integer> and C<use bigint>: the
+former will not affect assignments to variables and the return value of
+some functions. C<bigint> truncates these results to integer too:
+
+ # perl -Minteger -wle 'print 3.2'
+ 3.2
+ # perl -Minteger -wle 'print 3.2 + 0'
+ 3
+ # perl -Mbigint -wle 'print 3.2'
+ 3
+ # perl -Mbigint -wle 'print 3.2 + 0'
+ 3
+
+ # perl -Mbigint -wle 'print exp(1) + 0'
+ 2
+ # perl -Mbigint -wle 'print exp(1)'
+ 2
+ # perl -Minteger -wle 'print exp(1)'
+ 2.71828182845905
+ # perl -Minteger -wle 'print exp(1) + 0'
+ 2
+
+In practice this makes seldom a difference as B<parts and results> of
+expressions will be truncated anyway, but this can, for instance, affect the
+return value of subroutines:
+
+ sub three_integer { use integer; return 3.2; }
+ sub three_bigint { use bigint; return 3.2; }
+
+ print three_integer(), " ", three_bigint(),"\n"; # prints "3.2 3"
+
+=head2 Options
+
+bigint recognizes some options that can be passed while loading it via use.
+The options can (currently) be either a single letter form, or the long form.
+The following options exist:
+
+=over 2
+
+=item a or accuracy
+
+This sets the accuracy for all math operations. The argument must be greater
+than or equal to zero. See Math::BigInt's bround() function for details.
+
+ perl -Mbigint=a,2 -le 'print 12345+1'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item p or precision
+
+This sets the precision for all math operations. The argument can be any
+integer. Negative values mean a fixed number of digits after the dot, and
+are <B>ignored</B> since all operations happen in integer space.
+A positive value rounds to this digit left from the dot. 0 or 1 mean round to
+integer and are ignore like negative values.
+
+See Math::BigInt's bfround() function for details.
+
+ perl -Mbignum=p,5 -le 'print 123456789+123'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item t or trace
+
+This enables a trace mode and is primarily for debugging bigint or
+Math::BigInt.
+
+=item hex
+
+Override the built-in hex() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item oct
+
+Override the built-in oct() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item l, lib, try or only
+
+Load a different math lib, see L<Math Library>.
+
+ perl -Mbigint=lib,GMP -e 'print 2 ** 512'
+ perl -Mbigint=try,GMP -e 'print 2 ** 512'
+ perl -Mbigint=only,GMP -e 'print 2 ** 512'
+
+Currently there is no way to specify more than one library on the command
+line. This means the following does not work:
+
+ perl -Mbignum=l,GMP,Pari -e 'print 2 ** 512'
+
+This will be hopefully fixed soon ;)
+
+=item v or version
+
+This prints out the name and version of all modules used and then exits.
+
+ perl -Mbigint=v
+
+=back
+
+=head2 Math Library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use bigint lib => 'Calc';
+
+You can change this by using:
+
+ use bignum lib => 'GMP';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use bigint lib => 'Foo,Math::BigInt::Bar';
+
+Using C<lib> warns if none of the specified libraries can be found and
+L<Math::BigInt> did fall back to one of the default libraries.
+To supress this warning, use C<try> instead:
+
+ use bignum try => 'GMP';
+
+If you want the code to die instead of falling back, use C<only> instead:
+
+ use bignum only => 'GMP';
+
+Please see respective module documentation for further details.
+
+=head2 Internal Format
+
+The numbers are stored as objects, and their internals might change at anytime,
+especially between math operations. The objects also might belong to different
+classes, like Math::BigInt, or Math::BigInt::Lite. Mixing them together, even
+with normal scalars is not extraordinary, but normal and expected.
+
+You should not depend on the internal format, all accesses must go through
+accessor methods. E.g. looking at $x->{sign} is not a good idea since there
+is no guaranty that the object in question has such a hash key, nor is a hash
+underneath at all.
+
+=head2 Sign
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
+You can access it with the sign() method.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head2 Methods
+
+Since all numbers are now objects, you can use all functions that are part of
+the BigInt API. You can only use the bxxx() notation, and not the fxxx()
+notation, though.
+
+=over 2
+
+=item inf()
+
+A shortcut to return Math::BigInt->binf(). Useful because Perl does not always
+handle bareword C<inf> properly.
+
+=item NaN()
+
+A shortcut to return Math::BigInt->bnan(). Useful because Perl does not always
+handle bareword C<NaN> properly.
+
+=item e
+
+ # perl -Mbigint=e -wle 'print e'
+
+Returns Euler's number C<e>, aka exp(1). Note that under bigint, this is
+truncated to an integer, and hence simple '2'.
+
+=item PI
+
+ # perl -Mbigint=PI -wle 'print PI'
+
+Returns PI. Note that under bigint, this is truncated to an integer, and hence
+simple '3'.
+
+=item bexp()
+
+ bexp($power,$accuracy);
+
+Returns Euler's number C<e> raised to the appropriate power, to
+the wanted accuracy.
+
+Note that under bigint, the result is truncated to an integer.
+
+Example:
+
+ # perl -Mbigint=bexp -wle 'print bexp(1,80)'
+
+=item bpi()
+
+ bpi($accuracy);
+
+Returns PI to the wanted accuracy. Note that under bigint, this is truncated
+to an integer, and hence simple '3'.
+
+Example:
+
+ # perl -Mbigint=bpi -wle 'print bpi(80)'
+
+=item upgrade()
+
+Return the class that numbers are upgraded to, is in fact returning
+C<$Math::BigInt::upgrade>.
+
+=item in_effect()
+
+ use bigint;
+
+ print "in effect\n" if bigint::in_effect; # true
+ {
+ no bigint;
+ print "in effect\n" if bigint::in_effect; # false
+ }
+
+Returns true or false if C<bigint> is in effect in the current scope.
+
+This method only works on Perl v5.9.4 or later.
+
+=back
+
+=head2 MATH LIBRARY
+
+Math with the numbers is done (by default) by a module called
+
+=head2 Caveat
+
+But a warning is in order. When using the following to make a copy of a number,
+only a shallow copy will be made.
+
+ $x = 9; $y = $x;
+ $x = $y = 7;
+
+Using the copy or the original with overloaded math is okay, e.g. the
+following work:
+
+ $x = 9; $y = $x;
+ print $x + 1, " ", $y,"\n"; # prints 10 9
+
+but calling any method that modifies the number directly will result in
+B<both> the original and the copy being destroyed:
+
+ $x = 9; $y = $x;
+ print $x->badd(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->binc(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->bmul(2), " ", $y,"\n"; # prints 18 18
+
+Using methods that do not modify, but testthe contents works:
+
+ $x = 9; $y = $x;
+ $z = 9 if $x->is_zero(); # works fine
+
+See the documentation about the copy constructor and C<=> in overload, as
+well as the documentation in BigInt for further details.
+
+=head1 CAVAETS
+
+=over 2
+
+=item in_effect()
+
+This method only works on Perl v5.9.4 or later.
+
+=item hex()/oct()
+
+C<bigint> overrides these routines with versions that can also handle
+big integer values. Under Perl prior to version v5.9.4, however, this
+will not happen unless you specifically ask for it with the two
+import tags "hex" and "oct" - and then it will be global and cannot be
+disabled inside a scope with "no bigint":
+
+ use bigint qw/hex oct/;
+
+ print hex("0x1234567890123456");
+ {
+ no bigint;
+ print hex("0x1234567890123456");
+ }
+
+The second call to hex() will warn about a non-portable constant.
+
+Compare this to:
+
+ use bigint;
+
+ # will warn only under Perl older than v5.9.4
+ print hex("0x1234567890123456");
+
+=back
+
+=head1 MODULES USED
+
+C<bigint> is just a thin wrapper around various modules of the Math::BigInt
+family. Think of it as the head of the family, who runs the shop, and orders
+the others to do the work.
+
+The following modules are currently used by bigint:
+
+ Math::BigInt::Lite (for speed, and only if it is loadable)
+ Math::BigInt
+
+=head1 EXAMPLES
+
+Some cool command line examples to impress the Python crowd ;) You might want
+to compare them to the results under -Mbignum or -Mbigrat:
+
+ perl -Mbigint -le 'print sqrt(33)'
+ perl -Mbigint -le 'print 2*255'
+ perl -Mbigint -le 'print 4.5+2*255'
+ perl -Mbigint -le 'print 3/7 + 5/7 + 8/3'
+ perl -Mbigint -le 'print 123->is_odd()'
+ perl -Mbigint -le 'print log(2)'
+ perl -Mbigint -le 'print 2 ** 0.5'
+ perl -Mbigint=a,65 -le 'print 2 ** 0.2'
+ perl -Mbignum=a,65,l,GMP -le 'print 7 ** 7777'
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Especially L<bigrat> as in C<perl -Mbigrat -le 'print 1/3+1/4'> and
+L<bignum> as in C<perl -Mbignum -le 'print sqrt(2)'>.
+
+L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
+as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> in early 2002 - 2007.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/bignum.pm b/Master/tlpkg/tlperl/lib/bignum.pm
new file mode 100644
index 00000000000..2e075c8b5a7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bignum.pm
@@ -0,0 +1,681 @@
+package bignum;
+use 5.006;
+
+$VERSION = '0.23';
+use Exporter;
+@ISA = qw( bigint );
+@EXPORT_OK = qw( PI e bexp bpi );
+@EXPORT = qw( inf NaN );
+
+use strict;
+use overload;
+require bigint; # no "use" to avoid import being called
+
+##############################################################################
+
+BEGIN
+ {
+ *inf = \&bigint::inf;
+ *NaN = \&bigint::NaN;
+ }
+
+# These are all alike, and thus faked by AUTOLOAD
+
+my @faked = qw/round_mode accuracy precision div_scale/;
+use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
+
+sub AUTOLOAD
+ {
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ no strict 'refs';
+ foreach my $n (@faked)
+ {
+ if ($n eq $name)
+ {
+ *{"bignum::$name"} = sub
+ {
+ my $self = shift;
+ no strict 'refs';
+ if (defined $_[0])
+ {
+ Math::BigInt->$name($_[0]);
+ return Math::BigFloat->$name($_[0]);
+ }
+ return Math::BigInt->$name();
+ };
+ return &$name;
+ }
+ }
+
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call bignum\-\>$name, not a valid method");
+ }
+
+sub unimport
+ {
+ $^H{bignum} = undef; # no longer in effect
+ overload::remove_constant('binary','','float','','integer');
+ }
+
+sub in_effect
+ {
+ my $level = shift || 0;
+ my $hinthash = (caller($level))[10];
+ $hinthash->{bignum};
+ }
+
+#############################################################################
+# the following two routines are for Perl 5.9.4 or later and are lexical
+
+sub _hex
+ {
+ return CORE::hex($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct
+ {
+ return CORE::oct($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ $^H{bignum} = 1; # we are in effect
+
+ my ($hex,$oct);
+
+ # for newer Perls override hex() and oct() with a lexical version:
+ if ($] > 5.009003)
+ {
+ $hex = \&_hex;
+ $oct = \&_oct;
+ }
+
+ # some defaults
+ my $lib = ''; my $lib_kind = 'try';
+ my $upgrade = 'Math::BigFloat';
+ my $downgrade = 'Math::BigInt';
+
+ my @import = ( ':constant' ); # drive it w/ constant
+ my @a = @_; my $l = scalar @_; my $j = 0;
+ my ($ver,$trace); # version? trace?
+ my ($a,$p); # accuracy, precision
+ for ( my $i = 0; $i < $l ; $i++,$j++ )
+ {
+ if ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] eq 'downgrade')
+ {
+ # this causes downgrading
+ $downgrade = $_[$i+1]; # or undef to disable
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(l|lib|try|only)$/)
+ {
+ # this causes a different low lib to take care...
+ $lib_kind = $1; $lib_kind = 'lib' if $lib_kind eq 'l';
+ $lib = $_[$i+1] || '';
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(a|accuracy)$/)
+ {
+ $a = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(p|precision)$/)
+ {
+ $p = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(v|version)$/)
+ {
+ $ver = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] =~ /^(t|trace)$/)
+ {
+ $trace = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] eq 'hex')
+ {
+ splice @a, $j, 1; $j --;
+ $hex = \&bigint::_hex_global;
+ }
+ elsif ($_[$i] eq 'oct')
+ {
+ splice @a, $j, 1; $j --;
+ $oct = \&bigint::_oct_global;
+ }
+ elsif ($_[$i] !~ /^(PI|e|bexp|bpi)\z/)
+ {
+ die ("unknown option $_[$i]");
+ }
+ }
+ my $class;
+ $_lite = 0; # using M::BI::L ?
+ if ($trace)
+ {
+ require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
+ $upgrade = 'Math::BigFloat::Trace';
+ }
+ else
+ {
+ # see if we can find Math::BigInt::Lite
+ if (!defined $a && !defined $p) # rounding won't work to well
+ {
+ eval 'require Math::BigInt::Lite;';
+ if ($@ eq '')
+ {
+ @import = ( ); # :constant in Lite, not MBI
+ Math::BigInt::Lite->import( ':constant' );
+ $_lite= 1; # signal okay
+ }
+ }
+ require Math::BigInt if $_lite == 0; # not already loaded?
+ $class = 'Math::BigInt'; # regardless of MBIL or not
+ }
+ push @import, $lib_kind => $lib if $lib ne '';
+ # Math::BigInt::Trace or plain Math::BigInt
+ $class->import(@import, upgrade => $upgrade);
+
+ if ($trace)
+ {
+ require Math::BigFloat::Trace; $class = 'Math::BigFloat::Trace';
+ $downgrade = 'Math::BigInt::Trace';
+ }
+ else
+ {
+ require Math::BigFloat; $class = 'Math::BigFloat';
+ }
+ $class->import(':constant','downgrade',$downgrade);
+
+ bignum->accuracy($a) if defined $a;
+ bignum->precision($p) if defined $p;
+ if ($ver)
+ {
+ print "bignum\t\t\t v$VERSION\n";
+ print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
+ print "Math::BigInt\t\t v$Math::BigInt::VERSION";
+ my $config = Math::BigInt->config();
+ print " lib => $config->{lib} v$config->{lib_version}\n";
+ print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n";
+ exit;
+ }
+
+ # Take care of octal/hexadecimal constants
+ overload::constant binary => sub { bigint::_binary_constant(shift) };
+
+ # if another big* was already loaded:
+ my ($package) = caller();
+
+ no strict 'refs';
+ if (!defined *{"${package}::inf"})
+ {
+ $self->export_to_level(1,$self,@a); # export inf and NaN
+ }
+ {
+ no warnings 'redefine';
+ *CORE::GLOBAL::oct = $oct if $oct;
+ *CORE::GLOBAL::hex = $hex if $hex;
+ }
+ }
+
+sub PI () { Math::BigFloat->new('3.141592653589793238462643383279502884197'); }
+sub e () { Math::BigFloat->new('2.718281828459045235360287471352662497757'); }
+sub bpi ($) { Math::BigFloat::bpi(@_); }
+sub bexp ($$) { my $x = Math::BigFloat->new($_[0]); $x->bexp($_[1]); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+bignum - Transparent BigNumber support for Perl
+
+=head1 SYNOPSIS
+
+ use bignum;
+
+ $x = 2 + 4.5,"\n"; # BigFloat 6.5
+ print 2 ** 512 * 0.1,"\n"; # really is what you think it is
+ print inf * inf,"\n"; # prints inf
+ print NaN * 3,"\n"; # prints NaN
+
+ {
+ no bignum;
+ print 2 ** 256,"\n"; # a normal Perl scalar now
+ }
+
+ # for older Perls, note that this will be global:
+ use bignum qw/hex oct/;
+ print hex("0x1234567890123490"),"\n";
+ print oct("01234567890123490"),"\n";
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded. Integer and
+floating-point constants are created as proper BigInts or BigFloats,
+respectively.
+
+If you do
+
+ use bignum;
+
+at the top of your script, Math::BigFloat and Math::BigInt will be loaded
+and any constant number will be converted to an object (Math::BigFloat for
+floats like 3.1415 and Math::BigInt for integers like 1234).
+
+So, the following line:
+
+ $x = 1234;
+
+creates actually a Math::BigInt and stores a reference to in $x.
+This happens transparently and behind your back, so to speak.
+
+You can see this with the following:
+
+ perl -Mbignum -le 'print ref(1234)'
+
+Don't worry if it says Math::BigInt::Lite, bignum and friends will use Lite
+if it is installed since it is faster for some operations. It will be
+automatically upgraded to BigInt whenever necessary:
+
+ perl -Mbignum -le 'print ref(2**255)'
+
+This also means it is a bad idea to check for some specific package, since
+the actual contents of $x might be something unexpected. Due to the
+transparent way of bignum C<ref()> should not be necessary, anyway.
+
+Since Math::BigInt and BigFloat also overload the normal math operations,
+the following line will still work:
+
+ perl -Mbignum -le 'print ref(1234+1234)'
+
+Since numbers are actually objects, you can call all the usual methods from
+BigInt/BigFloat on them. This even works to some extent on expressions:
+
+ perl -Mbignum -le '$x = 1234; print $x->bdec()'
+ perl -Mbignum -le 'print 1234->copy()->binc();'
+ perl -Mbignum -le 'print 1234->copy()->binc->badd(6);'
+ perl -Mbignum -le 'print +(1234)->copy()->binc()'
+
+(Note that print doesn't do what you expect if the expression starts with
+'(' hence the C<+>)
+
+You can even chain the operations together as usual:
+
+ perl -Mbignum -le 'print 1234->copy()->binc->badd(6);'
+ 1241
+
+Under bignum (or bigint or bigrat), Perl will "upgrade" the numbers
+appropriately. This means that:
+
+ perl -Mbignum -le 'print 1234+4.5'
+ 1238.5
+
+will work correctly. These mixed cases don't do always work when using
+Math::BigInt or Math::BigFloat alone, or at least not in the way normal Perl
+scalars work.
+
+If you do want to work with large integers like under C<use integer;>, try
+C<use bigint;>:
+
+ perl -Mbigint -le 'print 1234.5+4.5'
+ 1238
+
+There is also C<use bigrat;> which gives you big rationals:
+
+ perl -Mbigrat -le 'print 1234+4.1'
+ 12381/10
+
+The entire upgrading/downgrading is still experimental and might not work
+as you expect or may even have bugs. You might get errors like this:
+
+ Can't use an undefined value as an ARRAY reference at
+ /usr/local/lib/perl5/5.8.0/Math/BigInt/Calc.pm line 864
+
+This means somewhere a routine got a BigFloat/Lite but expected a BigInt (or
+vice versa) and the upgrade/downgrad path was missing. This is a bug, please
+report it so that we can fix it.
+
+You might consider using just Math::BigInt or Math::BigFloat, since they
+allow you finer control over what get's done in which module/space. For
+instance, simple loop counters will be Math::BigInts under C<use bignum;> and
+this is slower than keeping them as Perl scalars:
+
+ perl -Mbignum -le 'for ($i = 0; $i < 10; $i++) { print ref($i); }'
+
+Please note the following does not work as expected (prints nothing), since
+overloading of '..' is not yet possible in Perl (as of v5.8.0):
+
+ perl -Mbignum -le 'for (1..2) { print ref($_); }'
+
+=head2 Options
+
+bignum recognizes some options that can be passed while loading it via use.
+The options can (currently) be either a single letter form, or the long form.
+The following options exist:
+
+=over 2
+
+=item a or accuracy
+
+This sets the accuracy for all math operations. The argument must be greater
+than or equal to zero. See Math::BigInt's bround() function for details.
+
+ perl -Mbignum=a,50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item p or precision
+
+This sets the precision for all math operations. The argument can be any
+integer. Negative values mean a fixed number of digits after the dot, while
+a positive value rounds to this digit left from the dot. 0 or 1 mean round to
+integer. See Math::BigInt's bfround() function for details.
+
+ perl -Mbignum=p,-50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item t or trace
+
+This enables a trace mode and is primarily for debugging bignum or
+Math::BigInt/Math::BigFloat.
+
+=item l or lib
+
+Load a different math lib, see L<MATH LIBRARY>.
+
+ perl -Mbignum=l,GMP -e 'print 2 ** 512'
+
+Currently there is no way to specify more than one library on the command
+line. This means the following does not work:
+
+ perl -Mbignum=l,GMP,Pari -e 'print 2 ** 512'
+
+This will be hopefully fixed soon ;)
+
+=item hex
+
+Override the built-in hex() method with a version that can handle big
+integers. Note that under Perl older than v5.9.4, this will be global
+and cannot be disabled with "no bigint;".
+
+=item oct
+
+Override the built-in oct() method with a version that can handle big
+integers. Note that under Perl older than v5.9.4, this will be global
+and cannot be disabled with "no bigint;".
+
+=item v or version
+
+This prints out the name and version of all modules used and then exits.
+
+ perl -Mbignum=v
+
+=back
+
+=head2 Methods
+
+Beside import() and AUTOLOAD() there are only a few other methods.
+
+Since all numbers are now objects, you can use all functions that are part of
+the BigInt or BigFloat API. It is wise to use only the bxxx() notation, and not
+the fxxx() notation, though. This makes it possible that the underlying object
+might morph into a different class than BigFloat.
+
+=head2 Caveats
+
+But a warning is in order. When using the following to make a copy of a number,
+only a shallow copy will be made.
+
+ $x = 9; $y = $x;
+ $x = $y = 7;
+
+If you want to make a real copy, use the following:
+
+ $y = $x->copy();
+
+Using the copy or the original with overloaded math is okay, e.g. the
+following work:
+
+ $x = 9; $y = $x;
+ print $x + 1, " ", $y,"\n"; # prints 10 9
+
+but calling any method that modifies the number directly will result in
+B<both> the original and the copy being destroyed:
+
+ $x = 9; $y = $x;
+ print $x->badd(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->binc(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->bmul(2), " ", $y,"\n"; # prints 18 18
+
+Using methods that do not modify, but test the contents works:
+
+ $x = 9; $y = $x;
+ $z = 9 if $x->is_zero(); # works fine
+
+See the documentation about the copy constructor and C<=> in overload, as
+well as the documentation in BigInt for further details.
+
+=over 2
+
+=item inf()
+
+A shortcut to return Math::BigInt->binf(). Useful because Perl does not always
+handle bareword C<inf> properly.
+
+=item NaN()
+
+A shortcut to return Math::BigInt->bnan(). Useful because Perl does not always
+handle bareword C<NaN> properly.
+
+=item e
+
+ # perl -Mbignum=e -wle 'print e'
+
+Returns Euler's number C<e>, aka exp(1).
+
+=item PI()
+
+ # perl -Mbignum=PI -wle 'print PI'
+
+Returns PI.
+
+=item bexp()
+
+ bexp($power,$accuracy);
+
+Returns Euler's number C<e> raised to the appropriate power, to
+the wanted accuracy.
+
+Example:
+
+ # perl -Mbignum=bexp -wle 'print bexp(1,80)'
+
+=item bpi()
+
+ bpi($accuracy);
+
+Returns PI to the wanted accuracy.
+
+Example:
+
+ # perl -Mbignum=bpi -wle 'print bpi(80)'
+
+=item upgrade()
+
+Return the class that numbers are upgraded to, is in fact returning
+C<$Math::BigInt::upgrade>.
+
+=item in_effect()
+
+ use bignum;
+
+ print "in effect\n" if bignum::in_effect; # true
+ {
+ no bignum;
+ print "in effect\n" if bignum::in_effect; # false
+ }
+
+Returns true or false if C<bignum> is in effect in the current scope.
+
+This method only works on Perl v5.9.4 or later.
+
+=back
+
+=head2 Math Library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use bignum lib => 'Calc';
+
+You can change this by using:
+
+ use bignum lib => 'GMP';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use bignum lib => 'Foo,Math::BigInt::Bar';
+
+Please see respective module documentation for further details.
+
+Using C<lib> warns if none of the specified libraries can be found and
+L<Math::BigInt> did fall back to one of the default libraries.
+To supress this warning, use C<try> instead:
+
+ use bignum try => 'GMP';
+
+If you want the code to die instead of falling back, use C<only> instead:
+
+ use bignum only => 'GMP';
+
+=head2 INTERNAL FORMAT
+
+The numbers are stored as objects, and their internals might change at anytime,
+especially between math operations. The objects also might belong to different
+classes, like Math::BigInt, or Math::BigFLoat. Mixing them together, even
+with normal scalars is not extraordinary, but normal and expected.
+
+You should not depend on the internal format, all accesses must go through
+accessor methods. E.g. looking at $x->{sign} is not a bright idea since there
+is no guaranty that the object in question has such a hashkey, nor is a hash
+underneath at all.
+
+=head2 SIGN
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf' and stored seperately.
+You can access it with the sign() method.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head1 CAVAETS
+
+=over 2
+
+=item in_effect()
+
+This method only works on Perl v5.9.4 or later.
+
+=item hex()/oct()
+
+C<bigint> overrides these routines with versions that can also handle
+big integer values. Under Perl prior to version v5.9.4, however, this
+will not happen unless you specifically ask for it with the two
+import tags "hex" and "oct" - and then it will be global and cannot be
+disabled inside a scope with "no bigint":
+
+ use bigint qw/hex oct/;
+
+ print hex("0x1234567890123456");
+ {
+ no bigint;
+ print hex("0x1234567890123456");
+ }
+
+The second call to hex() will warn about a non-portable constant.
+
+Compare this to:
+
+ use bigint;
+
+ # will warn only under older than v5.9.4
+ print hex("0x1234567890123456");
+
+=back
+
+=head1 MODULES USED
+
+C<bignum> is just a thin wrapper around various modules of the Math::BigInt
+family. Think of it as the head of the family, who runs the shop, and orders
+the others to do the work.
+
+The following modules are currently used by bignum:
+
+ Math::BigInt::Lite (for speed, and only if it is loadable)
+ Math::BigInt
+ Math::BigFloat
+
+=head1 EXAMPLES
+
+Some cool command line examples to impress the Python crowd ;)
+
+ perl -Mbignum -le 'print sqrt(33)'
+ perl -Mbignum -le 'print 2*255'
+ perl -Mbignum -le 'print 4.5+2*255'
+ perl -Mbignum -le 'print 3/7 + 5/7 + 8/3'
+ perl -Mbignum -le 'print 123->is_odd()'
+ perl -Mbignum -le 'print log(2)'
+ perl -Mbignum -le 'print exp(1)'
+ perl -Mbignum -le 'print 2 ** 0.5'
+ perl -Mbignum=a,65 -le 'print 2 ** 0.2'
+ perl -Mbignum=a,65,l,GMP -le 'print 7 ** 7777'
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Especially L<bigrat> as in C<perl -Mbigrat -le 'print 1/3+1/4'>.
+
+L<Math::BigFloat>, L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
+as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> in early 2002 - 2007.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/bigrat.pl b/Master/tlpkg/tlperl/lib/bigrat.pl
new file mode 100644
index 00000000000..f3b599591e7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bigrat.pl
@@ -0,0 +1,157 @@
+package bigrat;
+require "bigint.pl";
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Arbitrary size rational math package
+
+# by Mark Biggar
+#
+# Input values to these routines consist of strings of the form
+# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
+# Examples:
+# "+0/1" canonical zero value
+# "3" canonical value "+3/1"
+# " -123/123 123" canonical value "-1/1001"
+# "123 456/7890" canonical value "+20576/1315"
+# Output values always include a sign and no leading zeros or
+# white space.
+# This package makes use of the bigint package.
+# The string 'NaN' is used to represent the result when input arguments
+# that are not numbers, as well as the result of dividing by zero and
+# the sqrt of a negative number.
+# Extreamly naive algorthims are used.
+#
+# Routines provided are:
+#
+# rneg(RAT) return RAT negation
+# rabs(RAT) return RAT absolute value
+# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
+# radd(RAT,RAT) return RAT addition
+# rsub(RAT,RAT) return RAT subtraction
+# rmul(RAT,RAT) return RAT multiplication
+# rdiv(RAT,RAT) return RAT division
+# rmod(RAT) return (RAT,RAT) integer and fractional parts
+# rnorm(RAT) return RAT normalization
+# rsqrt(RAT, cycles) return RAT square root
+
+# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
+sub main'rnorm { #(string) return rat_num
+ local($_) = @_;
+ s/\s+//g;
+ if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
+ &norm($1, $3 ? $3 : '+1');
+ } else {
+ 'NaN';
+ }
+}
+
+# Normalize by reducing to lowest terms
+sub norm { #(bint, bint) return rat_num
+ local($num,$dom) = @_;
+ if ($num eq 'NaN') {
+ 'NaN';
+ } elsif ($dom eq 'NaN') {
+ 'NaN';
+ } elsif ($dom =~ /^[+-]?0+$/) {
+ 'NaN';
+ } else {
+ local($gcd) = &'bgcd($num,$dom);
+ $gcd =~ s/^-/+/;
+ if ($gcd ne '+1') {
+ $num = &'bdiv($num,$gcd);
+ $dom = &'bdiv($dom,$gcd);
+ } else {
+ $num = &'bnorm($num);
+ $dom = &'bnorm($dom);
+ }
+ substr($dom,$[,1) = '';
+ "$num/$dom";
+ }
+}
+
+# negation
+sub main'rneg { #(rat_num) return rat_num
+ local($_) = &'rnorm(@_);
+ tr/-+/+-/ if ($_ ne '+0/1');
+ $_;
+}
+
+# absolute value
+sub main'rabs { #(rat_num) return $rat_num
+ local($_) = &'rnorm(@_);
+ substr($_,$[,1) = '+' unless $_ eq 'NaN';
+ $_;
+}
+
+# multipication
+sub main'rmul { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
+}
+
+# division
+sub main'rdiv { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
+}
+
+# addition
+sub main'radd { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# subtraction
+sub main'rsub { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# comparison
+sub main'rcmp { #(rat_num, rat_num) return cond_code
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
+}
+
+# int and frac parts
+sub main'rmod { #(rat_num) return (rat_num,rat_num)
+ local($xn,$xd) = split('/',&'rnorm(@_));
+ local($i,$f) = &'bdiv($xn,$xd);
+ if (wantarray) {
+ ("$i/1", "$f/$xd");
+ } else {
+ "$i/1";
+ }
+}
+
+# square root by Newtons method.
+# cycles specifies the number of iterations default: 5
+sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
+ local($x, $scale) = (&'rnorm($_[$[]), $_[$[+1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($x =~ /^-/) {
+ 'NaN';
+ } else {
+ local($gscale, $guess) = (0, '+1/1');
+ $scale = 5 if (!$scale);
+ while ($gscale++ < $scale) {
+ $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
+ }
+ "$guess"; # quotes necessary due to perl bug
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/bigrat.pm b/Master/tlpkg/tlperl/lib/bigrat.pm
new file mode 100644
index 00000000000..10e8057abd0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bigrat.pm
@@ -0,0 +1,566 @@
+package bigrat;
+use 5.006;
+
+$VERSION = '0.23';
+require Exporter;
+@ISA = qw( bigint );
+@EXPORT_OK = qw( PI e bpi bexp );
+@EXPORT = qw( inf NaN );
+
+use strict;
+use overload;
+require bigint; # no "use" to avoid callind import
+
+##############################################################################
+
+BEGIN
+ {
+ *inf = \&bigint::inf;
+ *NaN = \&bigint::NaN;
+ }
+
+# These are all alike, and thus faked by AUTOLOAD
+
+my @faked = qw/round_mode accuracy precision div_scale/;
+use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
+
+sub AUTOLOAD
+ {
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*:://; # split package
+ no strict 'refs';
+ foreach my $n (@faked)
+ {
+ if ($n eq $name)
+ {
+ *{"bigrat::$name"} = sub
+ {
+ my $self = shift;
+ no strict 'refs';
+ if (defined $_[0])
+ {
+ Math::BigInt->$name($_[0]);
+ Math::BigFloat->$name($_[0]);
+ return Math::BigRat->$name($_[0]);
+ }
+ return Math::BigInt->$name();
+ };
+ return &$name;
+ }
+ }
+
+ # delayed load of Carp and avoid recursion
+ require Carp;
+ Carp::croak ("Can't call bigrat\-\>$name, not a valid method");
+ }
+
+sub unimport
+ {
+ $^H{bigrat} = undef; # no longer in effect
+ overload::remove_constant('binary','','float','','integer');
+ }
+
+sub in_effect
+ {
+ my $level = shift || 0;
+ my $hinthash = (caller($level))[10];
+ $hinthash->{bigrat};
+ }
+
+#############################################################################
+# the following two routines are for Perl 5.9.4 or later and are lexical
+
+sub _hex
+ {
+ return CORE::hex($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ $i = '0x'.$i unless $i =~ /^0x/;
+ Math::BigInt->new($i);
+ }
+
+sub _oct
+ {
+ return CORE::oct($_[0]) unless in_effect(1);
+ my $i = $_[0];
+ return Math::BigInt->from_oct($i) if $i =~ /^0[0-7]/;
+ Math::BigInt->new($i);
+ }
+
+sub import
+ {
+ my $self = shift;
+
+ # see also bignum->import() for additional comments
+
+ $^H{bigrat} = 1; # we are in effect
+
+ my ($hex,$oct);
+ # for newer Perls always override hex() and oct() with a lexical version:
+ if ($] > 5.009004)
+ {
+ $oct = \&_oct;
+ $hex = \&_hex;
+ }
+ # some defaults
+ my $lib = ''; my $lib_kind = 'try'; my $upgrade = 'Math::BigFloat';
+
+ my @import = ( ':constant' ); # drive it w/ constant
+ my @a = @_; my $l = scalar @_; my $j = 0;
+ my ($a,$p);
+ my ($ver,$trace); # version? trace?
+ for ( my $i = 0; $i < $l ; $i++,$j++ )
+ {
+ if ($_[$i] eq 'upgrade')
+ {
+ # this causes upgrading
+ $upgrade = $_[$i+1]; # or undef to disable
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s;
+ }
+ elsif ($_[$i] =~ /^(l|lib|try|only)$/)
+ {
+ # this causes a different low lib to take care...
+ $lib_kind = $1; $lib_kind = 'lib' if $lib_kind eq 'l';
+ $lib = $_[$i+1] || '';
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(a|accuracy)$/)
+ {
+ $a = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(p|precision)$/)
+ {
+ $p = $_[$i+1];
+ my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
+ splice @a, $j, $s; $j -= $s; $i++;
+ }
+ elsif ($_[$i] =~ /^(v|version)$/)
+ {
+ $ver = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] =~ /^(t|trace)$/)
+ {
+ $trace = 1;
+ splice @a, $j, 1; $j --;
+ }
+ elsif ($_[$i] eq 'hex')
+ {
+ splice @a, $j, 1; $j --;
+ $hex = \&bigint::_hex_global;
+ }
+ elsif ($_[$i] eq 'oct')
+ {
+ splice @a, $j, 1; $j --;
+ $oct = \&bigint::_oct_global;
+ }
+ elsif ($_[$i] !~ /^(PI|e|bpi|bexp)\z/)
+ {
+ die ("unknown option $_[$i]");
+ }
+ }
+ my $class;
+ $_lite = 0; # using M::BI::L ?
+ if ($trace)
+ {
+ require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
+ $upgrade = 'Math::BigFloat::Trace';
+ }
+ else
+ {
+ # see if we can find Math::BigInt::Lite
+ if (!defined $a && !defined $p) # rounding won't work to well
+ {
+ eval 'require Math::BigInt::Lite;';
+ if ($@ eq '')
+ {
+ @import = ( ); # :constant in Lite, not MBI
+ Math::BigInt::Lite->import( ':constant' );
+ $_lite= 1; # signal okay
+ }
+ }
+ require Math::BigInt if $_lite == 0; # not already loaded?
+ $class = 'Math::BigInt'; # regardless of MBIL or not
+ }
+ push @import, $lib_kind => $lib if $lib ne '';
+ # Math::BigInt::Trace or plain Math::BigInt
+ $class->import(@import, upgrade => $upgrade);
+
+ require Math::BigFloat;
+ Math::BigFloat->import( upgrade => 'Math::BigRat', ':constant' );
+ require Math::BigRat;
+
+ bigrat->accuracy($a) if defined $a;
+ bigrat->precision($p) if defined $p;
+ if ($ver)
+ {
+ print "bigrat\t\t\t v$VERSION\n";
+ print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
+ print "Math::BigInt\t\t v$Math::BigInt::VERSION";
+ my $config = Math::BigInt->config();
+ print " lib => $config->{lib} v$config->{lib_version}\n";
+ print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n";
+ print "Math::BigRat\t\t v$Math::BigRat::VERSION\n";
+ exit;
+ }
+
+ # Take care of octal/hexadecimal constants
+ overload::constant binary => sub { bigint::_binary_constant(shift) };
+
+ # if another big* was already loaded:
+ my ($package) = caller();
+
+ no strict 'refs';
+ if (!defined *{"${package}::inf"})
+ {
+ $self->export_to_level(1,$self,@a); # export inf and NaN
+ }
+ {
+ no warnings 'redefine';
+ *CORE::GLOBAL::oct = $oct if $oct;
+ *CORE::GLOBAL::hex = $hex if $hex;
+ }
+ }
+
+sub PI () { Math::BigFloat->new('3.141592653589793238462643383279502884197'); }
+sub e () { Math::BigFloat->new('2.718281828459045235360287471352662497757'); }
+
+sub bpi ($) { local $Math::BigFloat::upgrade; Math::BigFloat::bpi(@_); }
+
+sub bexp ($$)
+ {
+ local $Math::BigFloat::upgrade;
+ my $x = Math::BigFloat->new($_[0]); $x->bexp($_[1]);
+ }
+
+1;
+
+__END__
+
+=head1 NAME
+
+bigrat - Transparent BigNumber/BigRational support for Perl
+
+=head1 SYNOPSIS
+
+ use bigrat;
+
+ print 2 + 4.5,"\n"; # BigFloat 6.5
+ print 1/3 + 1/4,"\n"; # produces 7/12
+
+ {
+ no bigrat;
+ print 1/3,"\n"; # 0.33333...
+ }
+
+ # Note that this will make hex() and oct() be globally overriden:
+ use bigrat qw/hex oct/;
+ print hex("0x1234567890123490"),"\n";
+ print oct("01234567890123490"),"\n";
+
+=head1 DESCRIPTION
+
+All operators (including basic math operations) are overloaded. Integer and
+floating-point constants are created as proper BigInts or BigFloats,
+respectively.
+
+Other than L<bignum>, this module upgrades to Math::BigRat, meaning that
+instead of 2.5 you will get 2+1/2 as output.
+
+=head2 Modules Used
+
+C<bigrat> is just a thin wrapper around various modules of the Math::BigInt
+family. Think of it as the head of the family, who runs the shop, and orders
+the others to do the work.
+
+The following modules are currently used by bignum:
+
+ Math::BigInt::Lite (for speed, and only if it is loadable)
+ Math::BigInt
+ Math::BigFloat
+ Math::BigRat
+
+=head2 Math Library
+
+Math with the numbers is done (by default) by a module called
+Math::BigInt::Calc. This is equivalent to saying:
+
+ use bigrat lib => 'Calc';
+
+You can change this by using:
+
+ use bignum lib => 'GMP';
+
+The following would first try to find Math::BigInt::Foo, then
+Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
+
+ use bigrat lib => 'Foo,Math::BigInt::Bar';
+
+Using C<lib> warns if none of the specified libraries can be found and
+L<Math::BigInt> did fall back to one of the default libraries.
+To supress this warning, use C<try> instead:
+
+ use bignum try => 'GMP';
+
+If you want the code to die instead of falling back, use C<only> instead:
+
+ use bignum only => 'GMP';
+
+Please see respective module documentation for further details.
+
+=head2 Sign
+
+The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
+
+A sign of 'NaN' is used to represent the result when input arguments are not
+numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
+minus infinity. You will get '+inf' when dividing a positive number by 0, and
+'-inf' when dividing any negative number by 0.
+
+=head2 Methods
+
+Since all numbers are not objects, you can use all functions that are part of
+the BigInt or BigFloat API. It is wise to use only the bxxx() notation, and not
+the fxxx() notation, though. This makes you independed on the fact that the
+underlying object might morph into a different class than BigFloat.
+
+=over 2
+
+=item inf()
+
+A shortcut to return Math::BigInt->binf(). Useful because Perl does not always
+handle bareword C<inf> properly.
+
+=item NaN()
+
+A shortcut to return Math::BigInt->bnan(). Useful because Perl does not always
+handle bareword C<NaN> properly.
+
+=item e
+
+ # perl -Mbigrat=e -wle 'print e'
+
+Returns Euler's number C<e>, aka exp(1).
+
+=item PI
+
+ # perl -Mbigrat=PI -wle 'print PI'
+
+Returns PI.
+
+=item bexp()
+
+ bexp($power,$accuracy);
+
+
+Returns Euler's number C<e> raised to the appropriate power, to
+the wanted accuracy.
+
+Example:
+
+ # perl -Mbigrat=bexp -wle 'print bexp(1,80)'
+
+=item bpi()
+
+ bpi($accuracy);
+
+Returns PI to the wanted accuracy.
+
+Example:
+
+ # perl -Mbigrat=bpi -wle 'print bpi(80)'
+
+=item upgrade()
+
+Return the class that numbers are upgraded to, is in fact returning
+C<$Math::BigInt::upgrade>.
+
+=item in_effect()
+
+ use bigrat;
+
+ print "in effect\n" if bigrat::in_effect; # true
+ {
+ no bigrat;
+ print "in effect\n" if bigrat::in_effect; # false
+ }
+
+Returns true or false if C<bigrat> is in effect in the current scope.
+
+This method only works on Perl v5.9.4 or later.
+
+=back
+
+=head2 MATH LIBRARY
+
+Math with the numbers is done (by default) by a module called
+
+=head2 Cavaet
+
+But a warning is in order. When using the following to make a copy of a number,
+only a shallow copy will be made.
+
+ $x = 9; $y = $x;
+ $x = $y = 7;
+
+If you want to make a real copy, use the following:
+
+ $y = $x->copy();
+
+Using the copy or the original with overloaded math is okay, e.g. the
+following work:
+
+ $x = 9; $y = $x;
+ print $x + 1, " ", $y,"\n"; # prints 10 9
+
+but calling any method that modifies the number directly will result in
+B<both> the original and the copy being destroyed:
+
+ $x = 9; $y = $x;
+ print $x->badd(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->binc(1), " ", $y,"\n"; # prints 10 10
+
+ $x = 9; $y = $x;
+ print $x->bmul(2), " ", $y,"\n"; # prints 18 18
+
+Using methods that do not modify, but testthe contents works:
+
+ $x = 9; $y = $x;
+ $z = 9 if $x->is_zero(); # works fine
+
+See the documentation about the copy constructor and C<=> in overload, as
+well as the documentation in BigInt for further details.
+
+=head2 Options
+
+bignum recognizes some options that can be passed while loading it via use.
+The options can (currently) be either a single letter form, or the long form.
+The following options exist:
+
+=over 2
+
+=item a or accuracy
+
+This sets the accuracy for all math operations. The argument must be greater
+than or equal to zero. See Math::BigInt's bround() function for details.
+
+ perl -Mbigrat=a,50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item p or precision
+
+This sets the precision for all math operations. The argument can be any
+integer. Negative values mean a fixed number of digits after the dot, while
+a positive value rounds to this digit left from the dot. 0 or 1 mean round to
+integer. See Math::BigInt's bfround() function for details.
+
+ perl -Mbigrat=p,-50 -le 'print sqrt(20)'
+
+Note that setting precision and accurary at the same time is not possible.
+
+=item t or trace
+
+This enables a trace mode and is primarily for debugging bignum or
+Math::BigInt/Math::BigFloat.
+
+=item l or lib
+
+Load a different math lib, see L<MATH LIBRARY>.
+
+ perl -Mbigrat=l,GMP -e 'print 2 ** 512'
+
+Currently there is no way to specify more than one library on the command
+line. This means the following does not work:
+
+ perl -Mbignum=l,GMP,Pari -e 'print 2 ** 512'
+
+This will be hopefully fixed soon ;)
+
+=item hex
+
+Override the built-in hex() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item oct
+
+Override the built-in oct() method with a version that can handle big
+integers. Note that under Perl v5.9.4 or ealier, this will be global
+and cannot be disabled with "no bigint;".
+
+=item v or version
+
+This prints out the name and version of all modules used and then exits.
+
+ perl -Mbigrat=v
+
+=back
+
+=head1 CAVAETS
+
+=over 2
+
+=item in_effect()
+
+This method only works on Perl v5.9.4 or later.
+
+=item hex()/oct()
+
+C<bigint> overrides these routines with versions that can also handle
+big integer values. Under Perl prior to version v5.9.4, however, this
+will not happen unless you specifically ask for it with the two
+import tags "hex" and "oct" - and then it will be global and cannot be
+disabled inside a scope with "no bigint":
+
+ use bigint qw/hex oct/;
+
+ print hex("0x1234567890123456");
+ {
+ no bigint;
+ print hex("0x1234567890123456");
+ }
+
+The second call to hex() will warn about a non-portable constant.
+
+Compare this to:
+
+ use bigint;
+
+ # will warn only under Perl older than v5.9.4
+ print hex("0x1234567890123456");
+
+=back
+
+=head1 EXAMPLES
+
+ perl -Mbigrat -le 'print sqrt(33)'
+ perl -Mbigrat -le 'print 2*255'
+ perl -Mbigrat -le 'print 4.5+2*255'
+ perl -Mbigrat -le 'print 3/7 + 5/7 + 8/3'
+ perl -Mbigrat -le 'print 12->is_odd()';
+ perl -Mbignum=l,GMP -le 'print 7 ** 7777'
+
+=head1 LICENSE
+
+This program is free software; you may redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Especially L<bignum>.
+
+L<Math::BigFloat>, L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
+as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
+
+=head1 AUTHORS
+
+(C) by Tels L<http://bloodgate.com/> in early 2002 - 2007.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/blib.pm b/Master/tlpkg/tlperl/lib/blib.pm
new file mode 100644
index 00000000000..f755e29b0de
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/blib.pm
@@ -0,0 +1,97 @@
+package blib;
+
+=head1 NAME
+
+blib - Use MakeMaker's uninstalled version of a package
+
+=head1 SYNOPSIS
+
+ perl -Mblib script [args...]
+
+ perl -Mblib=dir script [args...]
+
+=head1 DESCRIPTION
+
+Looks for MakeMaker-like I<'blib'> directory structure starting in
+I<dir> (or current directory) and working back up to five levels of '..'.
+
+Intended for use on command line with B<-M> option as a way of testing
+arbitrary scripts against an uninstalled version of a package.
+
+However it is possible to :
+
+ use blib;
+ or
+ use blib '..';
+
+etc. if you really must.
+
+=head1 BUGS
+
+Pollutes global name space for development only task.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons nik@tiuk.ti.com
+
+=cut
+
+use Cwd;
+use File::Spec;
+
+use vars qw($VERSION $Verbose);
+$VERSION = '1.04';
+$Verbose = 0;
+
+sub import
+{
+ my $package = shift;
+ my $dir;
+ if ($^O eq "MSWin32" && -f "Win32.xs") {
+ # We don't use getcwd() on Windows because it will internally
+ # call Win32::GetCwd(), which will get the Win32 module loaded.
+ # That means that it would not be possible to run `make test`
+ # for the Win32 module because blib.pm would always load the
+ # installed version before @INC gets updated with the blib path.
+ chomp($dir = `cd`);
+ }
+ else {
+ $dir = getcwd;
+ }
+ if ($^O eq 'VMS') { ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--; }
+ if (@_)
+ {
+ $dir = shift;
+ $dir =~ s/blib\z//;
+ $dir =~ s,/+\z,,;
+ $dir = File::Spec->curdir unless ($dir);
+ die "$dir is not a directory\n" unless (-d $dir);
+ }
+ my $i = 5;
+ my($blib, $blib_lib, $blib_arch);
+ while ($i--)
+ {
+ $blib = File::Spec->catdir($dir, "blib");
+ $blib_lib = File::Spec->catdir($blib, "lib");
+
+ if ($^O eq 'MacOS')
+ {
+ $blib_arch = File::Spec->catdir($blib_lib, $MacPerl::Architecture);
+ }
+ else
+ {
+ $blib_arch = File::Spec->catdir($blib, "arch");
+ }
+
+ if (-d $blib && -d $blib_arch && -d $blib_lib)
+ {
+ unshift(@INC,$blib_arch,$blib_lib);
+ warn "Using $blib\n" if $Verbose;
+ return;
+ }
+ $dir = File::Spec->catdir($dir, File::Spec->updir);
+ }
+ die "Cannot find blib even in $dir\n";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/bytes.pm b/Master/tlpkg/tlperl/lib/bytes.pm
new file mode 100644
index 00000000000..6dad41ad9ff
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bytes.pm
@@ -0,0 +1,100 @@
+package bytes;
+
+our $VERSION = '1.04';
+
+$bytes::hint_bits = 0x00000008;
+
+sub import {
+ $^H |= $bytes::hint_bits;
+}
+
+sub unimport {
+ $^H &= ~$bytes::hint_bits;
+}
+
+sub AUTOLOAD {
+ require "bytes_heavy.pl";
+ goto &$AUTOLOAD if defined &$AUTOLOAD;
+ require Carp;
+ Carp::croak("Undefined subroutine $AUTOLOAD called");
+}
+
+sub length (_);
+sub chr (_);
+sub ord (_);
+sub substr ($$;$$);
+sub index ($$;$);
+sub rindex ($$;$);
+
+1;
+__END__
+
+=head1 NAME
+
+bytes - Perl pragma to force byte semantics rather than character semantics
+
+=head1 NOTICE
+
+This pragma reflects early attempts to incorporate Unicode into perl and
+has since been superseded. It breaks encapsulation (i.e. it exposes the
+innards of how the perl executable currently happens to store a string),
+and use of this module for anything other than debugging purposes is
+strongly discouraged. If you feel that the functions here within might be
+useful for your application, this possibly indicates a mismatch between
+your mental model of Perl Unicode and the current reality. In that case,
+you may wish to read some of the perl Unicode documentation:
+L<perluniintro>, L<perlunitut>, L<perlunifaq> and L<perlunicode>.
+
+=head1 SYNOPSIS
+
+ use bytes;
+ ... chr(...); # or bytes::chr
+ ... index(...); # or bytes::index
+ ... length(...); # or bytes::length
+ ... ord(...); # or bytes::ord
+ ... rindex(...); # or bytes::rindex
+ ... substr(...); # or bytes::substr
+ no bytes;
+
+
+=head1 DESCRIPTION
+
+The C<use bytes> pragma disables character semantics for the rest of the
+lexical scope in which it appears. C<no bytes> can be used to reverse
+the effect of C<use bytes> within the current lexical scope.
+
+Perl normally assumes character semantics in the presence of character
+data (i.e. data that has come from a source that has been marked as
+being of a particular character encoding). When C<use bytes> is in
+effect, the encoding is temporarily ignored, and each string is treated
+as a series of bytes.
+
+As an example, when Perl sees C<$x = chr(400)>, it encodes the character
+in UTF-8 and stores it in $x. Then it is marked as character data, so,
+for instance, C<length $x> returns C<1>. However, in the scope of the
+C<bytes> pragma, $x is treated as a series of bytes - the bytes that make
+up the UTF8 encoding - and C<length $x> returns C<2>:
+
+ $x = chr(400);
+ print "Length is ", length $x, "\n"; # "Length is 1"
+ printf "Contents are %vd\n", $x; # "Contents are 400"
+ {
+ use bytes; # or "require bytes; bytes::length()"
+ print "Length is ", length $x, "\n"; # "Length is 2"
+ printf "Contents are %vd\n", $x; # "Contents are 198.144"
+ }
+
+chr(), ord(), substr(), index() and rindex() behave similarly.
+
+For more on the implications and differences between character
+semantics and byte semantics, see L<perluniintro> and L<perlunicode>.
+
+=head1 LIMITATIONS
+
+bytes::substr() does not work as an lvalue().
+
+=head1 SEE ALSO
+
+L<perluniintro>, L<perlunicode>, L<utf8>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/bytes_heavy.pl b/Master/tlpkg/tlperl/lib/bytes_heavy.pl
new file mode 100644
index 00000000000..680c66ce921
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/bytes_heavy.pl
@@ -0,0 +1,40 @@
+package bytes;
+
+sub length (_) {
+ BEGIN { bytes::import() }
+ return CORE::length($_[0]);
+}
+
+sub substr ($$;$$) {
+ BEGIN { bytes::import() }
+ return
+ @_ == 2 ? CORE::substr($_[0], $_[1]) :
+ @_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) :
+ CORE::substr($_[0], $_[1], $_[2], $_[3]) ;
+}
+
+sub ord (_) {
+ BEGIN { bytes::import() }
+ return CORE::ord($_[0]);
+}
+
+sub chr (_) {
+ BEGIN { bytes::import() }
+ return CORE::chr($_[0]);
+}
+
+sub index ($$;$) {
+ BEGIN { bytes::import() }
+ return
+ @_ == 2 ? CORE::index($_[0], $_[1]) :
+ CORE::index($_[0], $_[1], $_[2]) ;
+}
+
+sub rindex ($$;$) {
+ BEGIN { bytes::import() }
+ return
+ @_ == 2 ? CORE::rindex($_[0], $_[1]) :
+ CORE::rindex($_[0], $_[1], $_[2]) ;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/cacheout.pl b/Master/tlpkg/tlperl/lib/cacheout.pl
new file mode 100644
index 00000000000..368e98ee21d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/cacheout.pl
@@ -0,0 +1,57 @@
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: FileCache
+
+# Open in their package.
+
+sub cacheout'open {
+ open($_[0], $_[1]);
+}
+
+# Close as well
+
+sub cacheout'close {
+ close($_[0]);
+}
+
+# But only this sub name is visible to them.
+
+sub cacheout {
+ package cacheout;
+
+ ($file) = @_;
+ if (!$isopen{$file}) {
+ if (++$numopen > $maxopen) {
+ local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
+ splice(@lru, $maxopen / 3);
+ $numopen -= @lru;
+ for (@lru) { &close($_); delete $isopen{$_}; }
+ }
+ &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+ || die "Can't create $file: $!\n";
+ }
+ $isopen{$file} = ++$seq;
+}
+
+package cacheout;
+
+$seq = 0;
+$numopen = 0;
+
+if (open(PARAM,'/usr/include/sys/param.h')) {
+ local($_, $.);
+ while (<PARAM>) {
+ $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+}
+$maxopen = 16 unless $maxopen;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/charnames.pm b/Master/tlpkg/tlperl/lib/charnames.pm
new file mode 100644
index 00000000000..ce0938bee91
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/charnames.pm
@@ -0,0 +1,577 @@
+package charnames;
+use strict;
+use warnings;
+use File::Spec;
+our $VERSION = '1.07';
+
+use bytes (); # for $bytes::hint_bits
+
+my %alias1 = (
+ # Icky 3.2 names with parentheses.
+ 'LINE FEED' => 'LINE FEED (LF)',
+ 'FORM FEED' => 'FORM FEED (FF)',
+ 'CARRIAGE RETURN' => 'CARRIAGE RETURN (CR)',
+ 'NEXT LINE' => 'NEXT LINE (NEL)',
+ # Convenience.
+ 'LF' => 'LINE FEED (LF)',
+ 'FF' => 'FORM FEED (FF)',
+ 'CR' => 'CARRIAGE RETURN (CR)',
+ 'NEL' => 'NEXT LINE (NEL)',
+ # More convenience. For futher convencience,
+ # it is suggested some way using using the NamesList
+ # aliases is implemented.
+ 'ZWNJ' => 'ZERO WIDTH NON-JOINER',
+ 'ZWJ' => 'ZERO WIDTH JOINER',
+ 'BOM' => 'BYTE ORDER MARK',
+ );
+
+my %alias2 = (
+ # Pre-3.2 compatibility (only for the first 256 characters).
+ 'HORIZONTAL TABULATION' => 'CHARACTER TABULATION',
+ 'VERTICAL TABULATION' => 'LINE TABULATION',
+ 'FILE SEPARATOR' => 'INFORMATION SEPARATOR FOUR',
+ 'GROUP SEPARATOR' => 'INFORMATION SEPARATOR THREE',
+ 'RECORD SEPARATOR' => 'INFORMATION SEPARATOR TWO',
+ 'UNIT SEPARATOR' => 'INFORMATION SEPARATOR ONE',
+ 'PARTIAL LINE DOWN' => 'PARTIAL LINE FORWARD',
+ 'PARTIAL LINE UP' => 'PARTIAL LINE BACKWARD',
+ );
+
+my %alias3 = (
+ # User defined aliasses. Even more convenient :)
+ );
+my $txt;
+
+sub croak
+{
+ require Carp; goto &Carp::croak;
+} # croak
+
+sub carp
+{
+ require Carp; goto &Carp::carp;
+} # carp
+
+sub alias (@)
+{
+ @_ or return %alias3;
+ my $alias = ref $_[0] ? $_[0] : { @_ };
+ @alias3{keys %$alias} = values %$alias;
+} # alias
+
+sub alias_file ($)
+{
+ my ($arg, $file) = @_;
+ if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
+ $file = $arg;
+ }
+ elsif ($arg =~ m/^\w+$/) {
+ $file = "unicore/${arg}_alias.pl";
+ }
+ else {
+ croak "Charnames alias files can only have identifier characters";
+ }
+ if (my @alias = do $file) {
+ @alias == 1 && !defined $alias[0] and
+ croak "$file cannot be used as alias file for charnames";
+ @alias % 2 and
+ croak "$file did not return a (valid) list of alias pairs";
+ alias (@alias);
+ return (1);
+ }
+ 0;
+} # alias_file
+
+# This is not optimized in any way yet
+sub charnames
+{
+ my $name = shift;
+
+ if (exists $alias1{$name}) {
+ $name = $alias1{$name};
+ }
+ elsif (exists $alias2{$name}) {
+ require warnings;
+ warnings::warnif('deprecated', qq{Unicode character name "$name" is deprecated, use "$alias2{$name}" instead});
+ $name = $alias2{$name};
+ }
+ elsif (exists $alias3{$name}) {
+ $name = $alias3{$name};
+ }
+
+ my $ord;
+ my @off;
+ my $fname;
+
+ if ($name eq "BYTE ORDER MARK") {
+ $fname = $name;
+ $ord = 0xFEFF;
+ } else {
+ ## Suck in the code/name list as a big string.
+ ## Lines look like:
+ ## "0052\t\tLATIN CAPITAL LETTER R\n"
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ ## @off will hold the index into the code/name string of the start and
+ ## end of the name as we find it.
+
+ ## If :full, look for the name exactly
+ if ($^H{charnames_full} and $txt =~ /\t\t\Q$name\E$/m) {
+ @off = ($-[0], $+[0]);
+ }
+
+ ## If we didn't get above, and :short allowed, look for the short name.
+ ## The short name is like "greek:Sigma"
+ unless (@off) {
+ if ($^H{charnames_short} and $name =~ /^(.+?):(.+)/s) {
+ my ($script, $cname) = ($1, $2);
+ my $case = $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
+ if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U\Q$cname\E$/m) {
+ @off = ($-[0], $+[0]);
+ }
+ }
+ }
+
+ ## If we still don't have it, check for the name among the loaded
+ ## scripts.
+ if (not @off) {
+ my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
+ for my $script (@{$^H{charnames_scripts}}) {
+ if ($txt =~ m/\t\t$script (?:$case )?LETTER \U\Q$name\E$/m) {
+ @off = ($-[0], $+[0]);
+ last;
+ }
+ }
+ }
+
+ ## If we don't have it by now, give up.
+ unless (@off) {
+ carp "Unknown charname '$name'";
+ return "\x{FFFD}";
+ }
+
+ ##
+ ## Now know where in the string the name starts.
+ ## The code, in hex, is before that.
+ ##
+ ## The code can be 4-6 characters long, so we've got to sort of
+ ## go look for it, just after the newline that comes before $off[0].
+ ##
+ ## This would be much easier if unicore/Name.pl had info in
+ ## a name/code order, instead of code/name order.
+ ##
+ ## The +1 after the rindex() is to skip past the newline we're finding,
+ ## or, if the rindex() fails, to put us to an offset of zero.
+ ##
+ my $hexstart = rindex($txt, "\n", $off[0]) + 1;
+
+ ## we know where it starts, so turn into number -
+ ## the ordinal for the char.
+ $ord = CORE::hex substr($txt, $hexstart, $off[0] - $hexstart);
+ }
+
+ if ($^H & $bytes::hint_bits) { # "use bytes" in effect?
+ use bytes;
+ return chr $ord if $ord <= 255;
+ my $hex = sprintf "%04x", $ord;
+ if (not defined $fname) {
+ $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
+ }
+ croak "Character 0x$hex with name '$fname' is above 0xFF";
+ }
+
+ no warnings 'utf8'; # allow even illegal characters
+ return pack "U", $ord;
+} # charnames
+
+sub import
+{
+ shift; ## ignore class name
+
+ if (not @_) {
+ carp("`use charnames' needs explicit imports list");
+ }
+ $^H{charnames} = \&charnames ;
+
+ ##
+ ## fill %h keys with our @_ args.
+ ##
+ my ($promote, %h, @args) = (0);
+ while (my $arg = shift) {
+ if ($arg eq ":alias") {
+ @_ or
+ croak ":alias needs an argument in charnames";
+ my $alias = shift;
+ if (ref $alias) {
+ ref $alias eq "HASH" or
+ croak "Only HASH reference supported as argument to :alias";
+ alias ($alias);
+ next;
+ }
+ if ($alias =~ m{:(\w+)$}) {
+ $1 eq "full" || $1 eq "short" and
+ croak ":alias cannot use existing pragma :$1 (reversed order?)";
+ alias_file ($1) and $promote = 1;
+ next;
+ }
+ alias_file ($alias);
+ next;
+ }
+ if (substr($arg, 0, 1) eq ':' and ! ($arg eq ":full" || $arg eq ":short")) {
+ warn "unsupported special '$arg' in charnames";
+ next;
+ }
+ push @args, $arg;
+ }
+ @args == 0 && $promote and @args = (":full");
+ @h{@args} = (1) x @args;
+
+ $^H{charnames_full} = delete $h{':full'};
+ $^H{charnames_short} = delete $h{':short'};
+ $^H{charnames_scripts} = [map uc, keys %h];
+
+ ##
+ ## If utf8? warnings are enabled, and some scripts were given,
+ ## see if at least we can find one letter of each script.
+ ##
+ if (warnings::enabled('utf8') && @{$^H{charnames_scripts}}) {
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ for my $script (@{$^H{charnames_scripts}}) {
+ if (not $txt =~ m/\t\t$script (?:CAPITAL |SMALL )?LETTER /) {
+ warnings::warn('utf8', "No such script: '$script'");
+ }
+ }
+ }
+} # import
+
+my %viacode;
+
+sub viacode
+{
+ if (@_ != 1) {
+ carp "charnames::viacode() expects one argument";
+ return;
+ }
+
+ my $arg = shift;
+
+ # this comes actually from Unicode::UCD, where it is the named
+ # function _getcode (), but it avoids the overhead of loading it
+ my $hex;
+ if ($arg =~ /^[1-9]\d*$/) {
+ $hex = sprintf "%04X", $arg;
+ } elsif ($arg =~ /^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/) {
+ $hex = $1;
+ } else {
+ carp("unexpected arg \"$arg\" to charnames::viacode()");
+ return;
+ }
+
+ # checking the length first is slightly faster
+ if (length($hex) > 5 && hex($hex) > 0x10FFFF) {
+ carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)";
+ return;
+ }
+
+ return $viacode{$hex} if exists $viacode{$hex};
+
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ return unless $txt =~ m/^$hex\t\t(.+)/m;
+
+ $viacode{$hex} = $1;
+} # viacode
+
+my %vianame;
+
+sub vianame
+{
+ if (@_ != 1) {
+ carp "charnames::vianame() expects one name argument";
+ return ()
+ }
+
+ my $arg = shift;
+
+ return chr CORE::hex $1 if $arg =~ /^U\+([0-9a-fA-F]+)$/;
+
+ return $vianame{$arg} if exists $vianame{$arg};
+
+ $txt = do "unicore/Name.pl" unless $txt;
+
+ my $pos = index $txt, "\t\t$arg\n";
+ if ($[ <= $pos) {
+ my $posLF = rindex $txt, "\n", $pos;
+ (my $code = substr $txt, $posLF + 1, 6) =~ tr/\t//d;
+ return $vianame{$arg} = CORE::hex $code;
+
+ # If $pos is at the 1st line, $posLF must be $[ - 1 (not found);
+ # then $posLF + 1 equals to $[ (at the beginning of $txt).
+ # Otherwise $posLF is the position of "\n";
+ # then $posLF + 1 must be the position of the next to "\n"
+ # (the beginning of the line).
+ # substr($txt, $posLF + 1, 6) may be "0000\t\t", "00A1\t\t",
+ # "10300\t", "100000", etc. So we can get the code via removing TAB.
+ } else {
+ return;
+ }
+} # vianame
+
+
+1;
+__END__
+
+=head1 NAME
+
+charnames - define character names for C<\N{named}> string literal escapes
+
+=head1 SYNOPSIS
+
+ use charnames ':full';
+ print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
+
+ use charnames ':short';
+ print "\N{greek:Sigma} is an upper-case sigma.\n";
+
+ use charnames qw(cyrillic greek);
+ print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
+
+ use charnames ":full", ":alias" => {
+ e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
+ };
+ print "\N{e_ACUTE} is a small letter e with an acute.\n";
+
+ use charnames ();
+ print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
+ printf "%04X", charnames::vianame("GOTHIC LETTER AHSA"); # prints "10330"
+
+=head1 DESCRIPTION
+
+Pragma C<use charnames> supports arguments C<:full>, C<:short>, script
+names and customized aliases. If C<:full> is present, for expansion of
+C<\N{CHARNAME}>, the string C<CHARNAME> is first looked up in the list of
+standard Unicode character names. If C<:short> is present, and
+C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
+as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
+with script name arguments, then for C<\N{CHARNAME}> the name
+C<CHARNAME> is looked up as a letter in the given scripts (in the
+specified order). Customized aliases are explained in L</CUSTOM ALIASES>.
+
+For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
+this pragma looks for the names
+
+ SCRIPTNAME CAPITAL LETTER CHARNAME
+ SCRIPTNAME SMALL LETTER CHARNAME
+ SCRIPTNAME LETTER CHARNAME
+
+in the table of standard Unicode names. If C<CHARNAME> is lowercase,
+then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant
+is ignored.
+
+Note that C<\N{...}> is compile-time, it's a special form of string
+constant used inside double-quoted strings: in other words, you cannot
+use variables inside the C<\N{...}>. If you want similar run-time
+functionality, use charnames::vianame().
+
+For the C0 and C1 control characters (U+0000..U+001F, U+0080..U+009F)
+as of Unicode 3.1, there are no official Unicode names but you can use
+instead the ISO 6429 names (LINE FEED, ESCAPE, and so forth). In
+Unicode 3.2 (as of Perl 5.8) some naming changes take place ISO 6429
+has been updated, see L</ALIASES>. Also note that the U+UU80, U+0081,
+U+0084, and U+0099 do not have names even in ISO 6429.
+
+Since the Unicode standard uses "U+HHHH", so can you: "\N{U+263a}"
+is the Unicode smiley face, or "\N{WHITE SMILING FACE}".
+
+=head1 ALIASES
+
+A few aliases have been defined for convenience: instead of having
+to use the official names
+
+ LINE FEED (LF)
+ FORM FEED (FF)
+ CARRIAGE RETURN (CR)
+ NEXT LINE (NEL)
+
+(yes, with parentheses) one can use
+
+ LINE FEED
+ FORM FEED
+ CARRIAGE RETURN
+ NEXT LINE
+ LF
+ FF
+ CR
+ NEL
+
+One can also use
+
+ BYTE ORDER MARK
+ BOM
+
+and
+
+ ZWNJ
+ ZWJ
+
+for ZERO WIDTH NON-JOINER and ZERO WIDTH JOINER.
+
+For backward compatibility one can use the old names for
+certain C0 and C1 controls
+
+ old new
+
+ HORIZONTAL TABULATION CHARACTER TABULATION
+ VERTICAL TABULATION LINE TABULATION
+ FILE SEPARATOR INFORMATION SEPARATOR FOUR
+ GROUP SEPARATOR INFORMATION SEPARATOR THREE
+ RECORD SEPARATOR INFORMATION SEPARATOR TWO
+ UNIT SEPARATOR INFORMATION SEPARATOR ONE
+ PARTIAL LINE DOWN PARTIAL LINE FORWARD
+ PARTIAL LINE UP PARTIAL LINE BACKWARD
+
+but the old names in addition to giving the character
+will also give a warning about being deprecated.
+
+=head1 CUSTOM ALIASES
+
+This version of charnames supports three mechanisms of adding local
+or customized aliases to standard Unicode naming conventions (:full).
+
+Note that an alias should not be something that is a legal curly
+brace-enclosed quantifier (see L<perlreref/QUANTIFIERS>). For example
+C<\N{123}> means to match 123 non-newline characters, and is not treated as an
+alias. Aliases are discouraged from beginning with anything other than an
+alphabetic character and from containing anything other than alphanumerics,
+spaces, dashes, colons, parentheses, and underscores. Currently they must be
+ASCII.
+
+=head2 Anonymous hashes
+
+ use charnames ":full", ":alias" => {
+ e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
+ };
+ my $str = "\N{e_ACUTE}";
+
+=head2 Alias file
+
+ use charnames ":full", ":alias" => "pro";
+
+ will try to read "unicore/pro_alias.pl" from the @INC path. This
+ file should return a list in plain perl:
+
+ (
+ A_GRAVE => "LATIN CAPITAL LETTER A WITH GRAVE",
+ A_CIRCUM => "LATIN CAPITAL LETTER A WITH CIRCUMFLEX",
+ A_DIAERES => "LATIN CAPITAL LETTER A WITH DIAERESIS",
+ A_TILDE => "LATIN CAPITAL LETTER A WITH TILDE",
+ A_BREVE => "LATIN CAPITAL LETTER A WITH BREVE",
+ A_RING => "LATIN CAPITAL LETTER A WITH RING ABOVE",
+ A_MACRON => "LATIN CAPITAL LETTER A WITH MACRON",
+ );
+
+=head2 Alias shortcut
+
+ use charnames ":alias" => ":pro";
+
+ works exactly the same as the alias pairs, only this time,
+ ":full" is inserted automatically as first argument (if no
+ other argument is given).
+
+=head1 charnames::viacode(code)
+
+Returns the full name of the character indicated by the numeric code.
+The example
+
+ print charnames::viacode(0x2722);
+
+prints "FOUR TEARDROP-SPOKED ASTERISK".
+
+Returns undef if no name is known for the code.
+
+This works only for the standard names, and does not yet apply
+to custom translators.
+
+Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
+SPACE", not "BYTE ORDER MARK".
+
+=head1 charnames::vianame(name)
+
+Returns the code point indicated by the name.
+The example
+
+ printf "%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
+
+prints "2722".
+
+Returns undef if the name is unknown.
+
+This works only for the standard names, and does not yet apply
+to custom translators.
+
+=head1 CUSTOM TRANSLATORS
+
+The mechanism of translation of C<\N{...}> escapes is general and not
+hardwired into F<charnames.pm>. A module can install custom
+translations (inside the scope which C<use>s the module) with the
+following magic incantation:
+
+ sub import {
+ shift;
+ $^H{charnames} = \&translator;
+ }
+
+Here translator() is a subroutine which takes C<CHARNAME> as an
+argument, and returns text to insert into the string instead of the
+C<\N{CHARNAME}> escape. Since the text to insert should be different
+in C<bytes> mode and out of it, the function should check the current
+state of C<bytes>-flag as in:
+
+ use bytes (); # for $bytes::hint_bits
+ sub translator {
+ if ($^H & $bytes::hint_bits) {
+ return bytes_translator(@_);
+ }
+ else {
+ return utf8_translator(@_);
+ }
+ }
+
+See L</CUSTOM ALIASES> above for restrictions on C<CHARNAME>.
+
+=head1 ILLEGAL CHARACTERS
+
+If you ask by name for a character that does not exist, a warning is given and
+the Unicode I<replacement character> "\x{FFFD}" is returned.
+
+If you ask by code for a character that is unassigned, no warning is
+given and C<undef> is returned. (Though if you ask for a code point
+past U+10FFFF you do get a warning.) See L</BUGS> below.
+
+=head1 BUGS
+
+viacode should return an empty string for unassigned in-range Unicode code
+points, as that is their correct current name.
+
+viacode(0) doesn't return C<NULL>, but C<undef>
+
+vianame returns a chr if the input name is of the form C<U+...>, and an ord
+otherwise. It is planned to change this to always return an ord.
+
+None of the functions work on almost all the Hangul syllable and CJK Unicode
+characters that have their code points as part of their names.
+
+Names must be ASCII characters only.
+
+Unicode standard named sequences are not recognized, such as
+C<LATIN CAPITAL LETTER A WITH MACRON AND GRAVE>
+(which should mean C<LATIN CAPITAL LETTER A WITH MACRON> with an additional
+C<COMBINING GRAVE ACCENT>).
+
+Since evaluation of the translation function happens in the middle of
+compilation (of a string literal), the translation function should not
+do any C<eval>s or C<require>s. This restriction should be lifted in
+a future version of Perl.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/complete.pl b/Master/tlpkg/tlperl/lib/complete.pl
new file mode 100644
index 00000000000..2fb3b33b85e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/complete.pl
@@ -0,0 +1,122 @@
+;#
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Term::Complete
+
+;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
+;#
+;# Author: Wayne Thompson
+;#
+;# Description:
+;# This routine provides word completion.
+;# (TAB) attempts word completion.
+;# (^D) prints completion list.
+;# (These may be changed by setting $Complete'complete, etc.)
+;#
+;# Diagnostics:
+;# Bell when word completion fails.
+;#
+;# Dependencies:
+;# The tty driver is put into raw mode.
+;#
+;# Bugs:
+;#
+;# Usage:
+;# $input = &Complete('prompt_string', *completion_list);
+;# or
+;# $input = &Complete('prompt_string', @completion_list);
+;#
+
+CONFIG: {
+ package Complete;
+
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+}
+
+sub Complete {
+ package Complete;
+
+ local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+ if ($_[1] =~ /^StB\0/) {
+ ($prompt, *_) = @_;
+ }
+ else {
+ $prompt = shift(@_);
+ }
+ @cmp_lst = sort(@_);
+
+ system('stty raw -echo');
+ LOOP: {
+ print($prompt, $return);
+ while (($_ = getc(STDIN)) ne "\r") {
+ CASE: {
+ # (TAB) attempt completion
+ $_ eq "\t" && do {
+ @match = grep(/^$return/, @cmp_lst);
+ $l = length($test = shift(@match));
+ unless ($#match < 0) {
+ 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(/^$return/, @cmp_lst)), "\r\n");
+ redo LOOP;
+ };
+
+ # (^U) kill
+ $_ eq $kill && do {
+ if ($r) {
+ undef $r;
+ undef $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('stty -raw echo');
+ print("\n");
+ $return;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/constant.pm b/Master/tlpkg/tlperl/lib/constant.pm
new file mode 100644
index 00000000000..3ee1a6f5b02
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/constant.pm
@@ -0,0 +1,391 @@
+package constant;
+use 5.005;
+use strict;
+use warnings::register;
+
+use vars qw($VERSION %declared);
+$VERSION = '1.20';
+
+#=======================================================================
+
+# Some names are evil choices.
+my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
+$keywords{UNITCHECK}++ if $] > 5.009;
+
+my %forced_into_main = map +($_, 1),
+ qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
+
+my %forbidden = (%keywords, %forced_into_main);
+
+my $str_end = $] >= 5.006 ? "\\z" : "\\Z";
+my $normal_constant_name = qr/^_?[^\W_0-9]\w*$str_end/;
+my $tolerable = qr/^[A-Za-z_]\w*$str_end/;
+my $boolean = qr/^[01]?$str_end/;
+
+BEGIN {
+ # We'd like to do use constant _CAN_PCS => $] > 5.009002
+ # but that's a bit tricky before we load the constant module :-)
+ # By doing this, we save 1 run time check for *every* call to import.
+ no strict 'refs';
+ my $const = $] > 5.009002;
+ *_CAN_PCS = sub () {$const};
+}
+
+#=======================================================================
+# import() - import symbols into user's namespace
+#
+# What we actually do is define a function in the caller's namespace
+# which returns the value. The function we create will normally
+# be inlined as a constant, thereby avoiding further sub calling
+# overhead.
+#=======================================================================
+sub import {
+ my $class = shift;
+ return unless @_; # Ignore 'use constant;'
+ my $constants;
+ my $multiple = ref $_[0];
+ my $pkg = caller;
+ my $flush_mro;
+ my $symtab;
+
+ if (_CAN_PCS) {
+ no strict 'refs';
+ $symtab = \%{$pkg . '::'};
+ };
+
+ if ( $multiple ) {
+ if (ref $_[0] ne 'HASH') {
+ require Carp;
+ Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
+ }
+ $constants = shift;
+ } else {
+ unless (defined $_[0]) {
+ require Carp;
+ Carp::croak("Can't use undef as constant name");
+ }
+ $constants->{+shift} = undef;
+ }
+
+ foreach my $name ( keys %$constants ) {
+ # Normal constant name
+ if ($name =~ $normal_constant_name and !$forbidden{$name}) {
+ # Everything is okay
+
+ # Name forced into main, but we're not in main. Fatal.
+ } elsif ($forced_into_main{$name} and $pkg ne 'main') {
+ require Carp;
+ Carp::croak("Constant name '$name' is forced into main::");
+
+ # Starts with double underscore. Fatal.
+ } elsif ($name =~ /^__/) {
+ require Carp;
+ Carp::croak("Constant name '$name' begins with '__'");
+
+ # Maybe the name is tolerable
+ } elsif ($name =~ $tolerable) {
+ # Then we'll warn only if you've asked for warnings
+ if (warnings::enabled()) {
+ if ($keywords{$name}) {
+ warnings::warn("Constant name '$name' is a Perl keyword");
+ } elsif ($forced_into_main{$name}) {
+ warnings::warn("Constant name '$name' is " .
+ "forced into package main::");
+ }
+ }
+
+ # Looks like a boolean
+ # use constant FRED == fred;
+ } elsif ($name =~ $boolean) {
+ require Carp;
+ if (@_) {
+ Carp::croak("Constant name '$name' is invalid");
+ } else {
+ Carp::croak("Constant name looks like boolean value");
+ }
+
+ } else {
+ # Must have bad characters
+ require Carp;
+ Carp::croak("Constant name '$name' has invalid characters");
+ }
+
+ {
+ no strict 'refs';
+ my $full_name = "${pkg}::$name";
+ $declared{$full_name}++;
+ if ($multiple || @_ == 1) {
+ my $scalar = $multiple ? $constants->{$name} : $_[0];
+ # The constant serves to optimise this entire block out on
+ # 5.8 and earlier.
+ if (_CAN_PCS && $symtab && !exists $symtab->{$name}) {
+ # No typeglob yet, so we can use a reference as space-
+ # efficient proxy for a constant subroutine
+ # The check in Perl_ck_rvconst knows that inlinable
+ # constants from cv_const_sv are read only. So we have to:
+ Internals::SvREADONLY($scalar, 1);
+ $symtab->{$name} = \$scalar;
+ ++$flush_mro;
+ } else {
+ *$full_name = sub () { $scalar };
+ }
+ } elsif (@_) {
+ my @list = @_;
+ *$full_name = sub () { @list };
+ } else {
+ *$full_name = sub () { };
+ }
+ }
+ }
+ # Flush the cache exactly once if we make any direct symbol table changes.
+ mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+constant - Perl pragma to declare constants
+
+=head1 SYNOPSIS
+
+ use constant PI => 4 * atan2(1, 1);
+ use constant DEBUG => 0;
+
+ print "Pi equals ", PI, "...\n" if DEBUG;
+
+ use constant {
+ SEC => 0,
+ MIN => 1,
+ HOUR => 2,
+ MDAY => 3,
+ MON => 4,
+ YEAR => 5,
+ WDAY => 6,
+ YDAY => 7,
+ ISDST => 8,
+ };
+
+ use constant WEEKDAYS => qw(
+ Sunday Monday Tuesday Wednesday Thursday Friday Saturday
+ );
+
+ print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
+
+=head1 DESCRIPTION
+
+This pragma allows you to declare constants at compile-time.
+
+When you declare a constant such as C<PI> using the method shown
+above, each machine your script runs upon can have as many digits
+of accuracy as it can use. Also, your program will be easier to
+read, more likely to be maintained (and maintained correctly), and
+far less likely to send a space probe to the wrong planet because
+nobody noticed the one equation in which you wrote C<3.14195>.
+
+When a constant is used in an expression, Perl replaces it with its
+value at compile time, and may then optimize the expression further.
+In particular, any code in an C<if (CONSTANT)> block will be optimized
+away if the constant is false.
+
+=head1 NOTES
+
+As with all C<use> directives, defining a constant happens at
+compile time. Thus, it's probably not correct to put a constant
+declaration inside of a conditional statement (like C<if ($foo)
+{ use constant ... }>).
+
+Constants defined using this module cannot be interpolated into
+strings like variables. However, concatenation works just fine:
+
+ print "Pi equals PI...\n"; # WRONG: does not expand "PI"
+ print "Pi equals ".PI."...\n"; # right
+
+Even though a reference may be declared as a constant, the reference may
+point to data which may be changed, as this code shows.
+
+ use constant ARRAY => [ 1,2,3,4 ];
+ print ARRAY->[1];
+ ARRAY->[1] = " be changed";
+ print ARRAY->[1];
+
+Dereferencing constant references incorrectly (such as using an array
+subscript on a constant hash reference, or vice versa) will be trapped at
+compile time.
+
+Constants belong to the package they are defined in. To refer to a
+constant defined in another package, specify the full package name, as
+in C<Some::Package::CONSTANT>. Constants may be exported by modules,
+and may also be called as either class or instance methods, that is,
+as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where
+C<$obj> is an instance of C<Some::Package>. Subclasses may define
+their own constants to override those in their base class.
+
+The use of all caps for constant names is merely a convention,
+although it is recommended in order to make constants stand out
+and to help avoid collisions with other barewords, keywords, and
+subroutine names. Constant names must begin with a letter or
+underscore. Names beginning with a double underscore are reserved. Some
+poor choices for names will generate warnings, if warnings are enabled at
+compile time.
+
+=head2 List constants
+
+Constants may be lists of more (or less) than one value. A constant
+with no values evaluates to C<undef> in scalar context. Note that
+constants with more than one value do I<not> return their last value in
+scalar context as one might expect. They currently return the number
+of values, but B<this may change in the future>. Do not use constants
+with multiple values in scalar context.
+
+B<NOTE:> This implies that the expression defining the value of a
+constant is evaluated in list context. This may produce surprises:
+
+ use constant TIMESTAMP => localtime; # WRONG!
+ use constant TIMESTAMP => scalar localtime; # right
+
+The first line above defines C<TIMESTAMP> as a 9-element list, as
+returned by C<localtime()> in list context. To set it to the string
+returned by C<localtime()> in scalar context, an explicit C<scalar>
+keyword is required.
+
+List constants are lists, not arrays. To index or slice them, they
+must be placed in parentheses.
+
+ my @workdays = WEEKDAYS[1 .. 5]; # WRONG!
+ my @workdays = (WEEKDAYS)[1 .. 5]; # right
+
+=head2 Defining multiple constants at once
+
+Instead of writing multiple C<use constant> statements, you may define
+multiple constants in a single statement by giving, instead of the
+constant name, a reference to a hash where the keys are the names of
+the constants to be defined. Obviously, all constants defined using
+this method must have a single value.
+
+ use constant {
+ FOO => "A single value",
+ BAR => "This", "won't", "work!", # Error!
+ };
+
+This is a fundamental limitation of the way hashes are constructed in
+Perl. The error messages produced when this happens will often be
+quite cryptic -- in the worst case there may be none at all, and
+you'll only later find that something is broken.
+
+When defining multiple constants, you cannot use the values of other
+constants defined in the same declaration. This is because the
+calling package doesn't know about any constant within that group
+until I<after> the C<use> statement is finished.
+
+ use constant {
+ BITMASK => 0xAFBAEBA8,
+ NEGMASK => ~BITMASK, # Error!
+ };
+
+=head2 Magic constants
+
+Magical values and references can be made into constants at compile
+time, allowing for way cool stuff like this. (These error numbers
+aren't totally portable, alas.)
+
+ use constant E2BIG => ($! = 7);
+ print E2BIG, "\n"; # something like "Arg list too long"
+ print 0+E2BIG, "\n"; # "7"
+
+You can't produce a tied constant by giving a tied scalar as the
+value. References to tied variables, however, can be used as
+constants without any problems.
+
+=head1 TECHNICAL NOTES
+
+In the current implementation, scalar constants are actually
+inlinable subroutines. As of version 5.004 of Perl, the appropriate
+scalar constant is inserted directly in place of some subroutine
+calls, thereby saving the overhead of a subroutine call. See
+L<perlsub/"Constant Functions"> for details about how and when this
+happens.
+
+In the rare case in which you need to discover at run time whether a
+particular constant has been declared via this module, you may use
+this function to examine the hash C<%constant::declared>. If the given
+constant name does not include a package name, the current package is
+used.
+
+ sub declared ($) {
+ use constant 1.01; # don't omit this!
+ my $name = shift;
+ $name =~ s/^::/main::/;
+ my $pkg = caller;
+ my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
+ $constant::declared{$full_name};
+ }
+
+=head1 CAVEATS
+
+In the current version of Perl, list constants are not inlined
+and some symbols may be redefined without generating a warning.
+
+It is not possible to have a subroutine or a keyword with the same
+name as a constant in the same package. This is probably a Good Thing.
+
+A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
+ENV INC SIG> is not allowed anywhere but in package C<main::>, for
+technical reasons.
+
+Unlike constants in some languages, these cannot be overridden
+on the command line or via environment variables.
+
+You can get into trouble if you use constants in a context which
+automatically quotes barewords (as is true for any subroutine call).
+For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
+be interpreted as a string. Use C<$hash{CONSTANT()}> or
+C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
+kicking in. Similarly, since the C<< => >> operator quotes a bareword
+immediately to its left, you have to say C<< CONSTANT() => 'value' >>
+(or simply use a comma in place of the big arrow) instead of
+C<< CONSTANT => 'value' >>.
+
+=head1 SEE ALSO
+
+L<Readonly> - Facility for creating read-only scalars, arrays, hashes.
+
+L<Const> - Facility for creating read-only variables. Similar to C<Readonly>,
+but uses C<SvREADONLY> instead of C<tie>.
+
+L<Attribute::Constant> - Make read-only variables via attribute
+
+L<Scalar::Readonly> - Perl extension to the C<SvREADONLY> scalar flag
+
+L<Hash::Util> - A selection of general-utility hash subroutines (mostly
+to lock/unlock keys and values)
+
+=head1 BUGS
+
+Please report any bugs or feature requests via the perlbug(1) utility.
+
+=head1 AUTHORS
+
+Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
+many other folks.
+
+Multiple constant declarations at once added by Casey West,
+E<lt>F<casey@geeknest.com>E<gt>.
+
+Documentation mostly rewritten by Ilmari Karonen,
+E<lt>F<perl@itz.pp.sci.fi>E<gt>.
+
+This program is maintained by the Perl 5 Porters.
+The CPAN distribution is maintained by SE<eacute>bastien Aperghis-Tramoni
+E<lt>F<sebastien@aperghis.net>E<gt>.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (C) 1997, 1999 Tom Phoenix
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/ctime.pl b/Master/tlpkg/tlperl/lib/ctime.pl
new file mode 100644
index 00000000000..1b91ec289f5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/ctime.pl
@@ -0,0 +1,62 @@
+;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: the POSIX ctime function
+
+;#
+;# Waldemar Kebsch, Federal Republic of Germany, November 1988
+;# kebsch.pad@nixpbe.UUCP
+;# Modified March 1990, Feb 1991 to properly handle timezones
+;# $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $
+;# Marion Hakanson (hakanson@cse.ogi.edu)
+;# Oregon Graduate Institute of Science and Technology
+;#
+;# usage:
+;#
+;# #include <ctime.pl> # see the -P and -I option in perl.man
+;# $Date = &ctime(time);
+
+CONFIG: {
+ package ctime;
+
+ @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
+ @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
+ 'Jul','Aug','Sep','Oct','Nov','Dec');
+}
+
+sub ctime {
+ package ctime;
+
+ local($time) = @_;
+ local($[) = 0;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
+
+ # Determine what time zone is in effect.
+ # Use GMT if TZ is defined as null, local time if TZ undefined.
+ # There's no portable way to find the system default timezone.
+
+ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
+ ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
+ ($TZ eq 'GMT') ? gmtime($time) : localtime($time);
+
+ # Hack to deal with 'PST8PDT' format of TZ
+ # Note that this can't deal with all the esoteric forms, but it
+ # does recognize the most common: [:]STDoff[DST[off][,rule]]
+
+ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
+ $TZ = $isdst ? $4 : $1;
+ }
+ $TZ .= ' ' unless $TZ eq '';
+
+ $year += 1900;
+ sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
+ $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
+}
+1;
diff --git a/Master/tlpkg/tlperl/lib/deprecate.pm b/Master/tlpkg/tlperl/lib/deprecate.pm
new file mode 100644
index 00000000000..7b92e0be7cb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/deprecate.pm
@@ -0,0 +1,105 @@
+package deprecate;
+use strict;
+use warnings;
+our $VERSION = 0.01;
+
+# our %Config can ignore %Config::Config, e.g. for testing
+our %Config;
+unless (%Config) { require Config; *Config = \%Config::Config; }
+
+sub import {
+ my ($package, $file, $line) = caller;
+ my $expect_leaf = "$package.pm";
+ $expect_leaf =~ s!::!/!g;
+
+ foreach my $pair ([qw(sitearchexp archlibexp)],
+ [qw(sitelibexp privlibexp)]) {
+ my ($site, $priv) = @Config{@$pair};
+ if ($^O eq 'VMS') {
+ for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
+ }
+ # Just in case anyone managed to configure with trailing /s
+ s!/*$!!g foreach $site, $priv;
+
+ next if $site eq $priv;
+ if (uc("$priv/$expect_leaf") eq uc($file)) {
+ my $call_depth=1;
+ my @caller;
+ while (@caller = caller $call_depth++) {
+ last if $caller[7] # use/require
+ and $caller[6] eq $expect_leaf; # the package file
+ }
+ unless (@caller) {
+ require Carp;
+ Carp::cluck(<<"EOM");
+Can't find use/require $expect_leaf in caller stack
+EOM
+ next;
+ }
+
+ # This is fragile, because it
+ # is directly poking in the internals of warnings.pm
+ my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9];
+
+ if (defined $callers_bitmask
+ && (vec($callers_bitmask, $warnings::Offsets{deprecated}, 1)
+ || vec($callers_bitmask, $warnings::Offsets{all}, 1))) {
+ warn <<"EOM";
+$package will be removed from the Perl core distribution in the next major release. Please install it from CPAN. It is being used at $call_file, line $call_line.
+EOM
+ }
+ return;
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+deprecate - Perl pragma for deprecating the core version of a module
+
+=head1 SYNOPSIS
+
+ use deprecate; # always deprecate the module in which this occurs
+
+ use if $] > 5.010, 'deprecate'; # conditionally deprecate the module
+
+
+=head1 DESCRIPTION
+
+This module is used using C<use deprecate;> (or something that calls
+C<< deprecate->import() >>, for example C<use if COND, deprecate;>).
+
+If the module that includes C<use deprecate> is located in a core library
+directory, a deprecation warning is issued, encouraging the user to use
+the version on CPAN. If that module is located in a site library, it is
+the CPAN version, and no warning is issued.
+
+=head2 EXPORT
+
+None by default. The only method is C<import>, called by C<use deprecate;>.
+
+
+=head1 SEE ALSO
+
+First example to C<use deprecate;> was L<Switch>.
+
+
+=head1 AUTHOR
+
+Original version by Nicholas Clark
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.10.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/diagnostics.pm b/Master/tlpkg/tlperl/lib/diagnostics.pm
new file mode 100644
index 00000000000..721b466fd05
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/diagnostics.pm
@@ -0,0 +1,648 @@
+package diagnostics;
+
+=head1 NAME
+
+diagnostics, splain - produce verbose warning diagnostics
+
+=head1 SYNOPSIS
+
+Using the C<diagnostics> pragma:
+
+ use diagnostics;
+ use diagnostics -verbose;
+
+ enable diagnostics;
+ disable diagnostics;
+
+Using the C<splain> standalone filter program:
+
+ perl program 2>diag.out
+ splain [-v] [-p] diag.out
+
+Using diagnostics to get stack traces from a misbehaving script:
+
+ perl -Mdiagnostics=-traceonly my_script.pl
+
+=head1 DESCRIPTION
+
+=head2 The C<diagnostics> Pragma
+
+This module extends the terse diagnostics normally emitted by both the
+perl compiler and the perl interpreter (from running perl with a -w
+switch or C<use warnings>), augmenting them with the more
+explicative and endearing descriptions found in L<perldiag>. Like the
+other pragmata, it affects the compilation phase of your program rather
+than merely the execution phase.
+
+To use in your program as a pragma, merely invoke
+
+ use diagnostics;
+
+at the start (or near the start) of your program. (Note
+that this I<does> enable perl's B<-w> flag.) Your whole
+compilation will then be subject(ed :-) to the enhanced diagnostics.
+These still go out B<STDERR>.
+
+Due to the interaction between runtime and compiletime issues,
+and because it's probably not a very good idea anyway,
+you may not use C<no diagnostics> to turn them off at compiletime.
+However, you may control their behaviour at runtime using the
+disable() and enable() methods to turn them off and on respectively.
+
+The B<-verbose> flag first prints out the L<perldiag> introduction before
+any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
+escape sequences for pagers.
+
+Warnings dispatched from perl itself (or more accurately, those that match
+descriptions found in L<perldiag>) are only displayed once (no duplicate
+descriptions). User code generated warnings a la warn() are unaffected,
+allowing duplicate user messages to be displayed.
+
+This module also adds a stack trace to the error message when perl dies.
+This is useful for pinpointing what caused the death. The B<-traceonly> (or
+just B<-t>) flag turns off the explanations of warning messages leaving just
+the stack traces. So if your script is dieing, run it again with
+
+ perl -Mdiagnostics=-traceonly my_bad_script
+
+to see the call stack at the time of death. By supplying the B<-warntrace>
+(or just B<-w>) flag, any warnings emitted will also come with a stack
+trace.
+
+=head2 The I<splain> Program
+
+While apparently a whole nuther program, I<splain> is actually nothing
+more than a link to the (executable) F<diagnostics.pm> module, as well as
+a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
+the C<use diagnostics -verbose> directive.
+The B<-p> flag is like the
+$diagnostics::PRETTY variable. Since you're post-processing with
+I<splain>, there's no sense in being able to enable() or disable() processing.
+
+Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
+
+=head1 EXAMPLES
+
+The following file is certain to trigger a few errors at both
+runtime and compiletime:
+
+ use diagnostics;
+ print NOWHERE "nothing\n";
+ print STDERR "\n\tThis message should be unadorned.\n";
+ warn "\tThis is a user warning";
+ print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
+ my $a, $b = scalar <STDIN>;
+ print "\n";
+ print $x/$y;
+
+If you prefer to run your program first and look at its problem
+afterwards, do this:
+
+ perl -w test.pl 2>test.out
+ ./splain < test.out
+
+Note that this is not in general possible in shells of more dubious heritage,
+as the theoretical
+
+ (perl -w test.pl >/dev/tty) >& test.out
+ ./splain < test.out
+
+Because you just moved the existing B<stdout> to somewhere else.
+
+If you don't want to modify your source code, but still have on-the-fly
+warnings, do this:
+
+ exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
+
+Nifty, eh?
+
+If you want to control warnings on the fly, do something like this.
+Make sure you do the C<use> first, or you won't be able to get
+at the enable() or disable() methods.
+
+ use diagnostics; # checks entire compilation phase
+ print "\ntime for 1st bogus diags: SQUAWKINGS\n";
+ print BOGUS1 'nada';
+ print "done with 1st bogus\n";
+
+ disable diagnostics; # only turns off runtime warnings
+ print "\ntime for 2nd bogus: (squelched)\n";
+ print BOGUS2 'nada';
+ print "done with 2nd bogus\n";
+
+ enable diagnostics; # turns back on runtime warnings
+ print "\ntime for 3rd bogus: SQUAWKINGS\n";
+ print BOGUS3 'nada';
+ print "done with 3rd bogus\n";
+
+ disable diagnostics;
+ print "\ntime for 4th bogus: (squelched)\n";
+ print BOGUS4 'nada';
+ print "done with 4th bogus\n";
+
+=head1 INTERNALS
+
+Diagnostic messages derive from the F<perldiag.pod> file when available at
+runtime. Otherwise, they may be embedded in the file itself when the
+splain package is built. See the F<Makefile> for details.
+
+If an extant $SIG{__WARN__} handler is discovered, it will continue
+to be honored, but only after the diagnostics::splainthis() function
+(the module's $SIG{__WARN__} interceptor) has had its way with your
+warnings.
+
+There is a $diagnostics::DEBUG variable you may set if you're desperately
+curious what sorts of things are being intercepted.
+
+ BEGIN { $diagnostics::DEBUG = 1 }
+
+
+=head1 BUGS
+
+Not being able to say "no diagnostics" is annoying, but may not be
+insurmountable.
+
+The C<-pretty> directive is called too late to affect matters.
+You have to do this instead, and I<before> you load the module.
+
+ BEGIN { $diagnostics::PRETTY = 1 }
+
+I could start up faster by delaying compilation until it should be
+needed, but this gets a "panic: top_level" when using the pragma form
+in Perl 5.001e.
+
+While it's true that this documentation is somewhat subserious, if you use
+a program named I<splain>, you should expect a bit of whimsy.
+
+=head1 AUTHOR
+
+Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
+
+=cut
+
+use strict;
+use 5.009001;
+use Carp;
+$Carp::Internal{__PACKAGE__.""}++;
+
+our $VERSION = '1.19';
+our $DEBUG;
+our $VERBOSE;
+our $PRETTY;
+our $TRACEONLY = 0;
+our $WARNTRACE = 0;
+
+use Config;
+my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+if ($^O eq 'VMS') {
+ require VMS::Filespec;
+ $privlib = VMS::Filespec::unixify($privlib);
+ $archlib = VMS::Filespec::unixify($archlib);
+}
+my @trypod = (
+ "$archlib/pod/perldiag.pod",
+ "$privlib/pod/perldiag-$Config{version}.pod",
+ "$privlib/pod/perldiag.pod",
+ "$archlib/pods/perldiag.pod",
+ "$privlib/pods/perldiag-$Config{version}.pod",
+ "$privlib/pods/perldiag.pod",
+ );
+# handy for development testing of new warnings etc
+unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
+(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
+
+if ($^O eq 'MacOS') {
+ # just updir one from each lib dir, we'll find it ...
+ ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
+}
+
+
+$DEBUG ||= 0;
+my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
+
+local $| = 1;
+my $_;
+local $.;
+
+my $standalone;
+my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
+
+CONFIG: {
+ our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
+
+ unless (caller) {
+ $standalone++;
+ require Getopt::Std;
+ Getopt::Std::getopts('pdvf:')
+ or die "Usage: $0 [-v] [-p] [-f splainpod]";
+ $PODFILE = $opt_f if $opt_f;
+ $DEBUG = 2 if $opt_d;
+ $VERBOSE = $opt_v;
+ $PRETTY = $opt_p;
+ }
+
+ if (open(POD_DIAG, $PODFILE)) {
+ warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
+ last CONFIG;
+ }
+
+ if (caller) {
+ INCPATH: {
+ for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
+ warn "Checking $file\n" if $DEBUG;
+ if (open(POD_DIAG, $file)) {
+ while (<POD_DIAG>) {
+ next unless
+ /^__END__\s*# wish diag dbase were more accessible/;
+ print STDERR "podfile is $file\n" if $DEBUG;
+ last INCPATH;
+ }
+ }
+ }
+ }
+ } else {
+ print STDERR "podfile is <DATA>\n" if $DEBUG;
+ *POD_DIAG = *main::DATA;
+ }
+}
+if (eof(POD_DIAG)) {
+ die "couldn't find diagnostic data in $PODFILE @INC $0";
+}
+
+
+%HTML_2_Troff = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A\\*'", # capital A, acute accent
+ # etc
+
+);
+
+%HTML_2_Latin_1 = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\xC1" # capital A, acute accent
+
+ # etc
+);
+
+%HTML_2_ASCII_7 = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A" # capital A, acute accent
+ # etc
+);
+
+our %HTML_Escapes;
+*HTML_Escapes = do {
+ if ($standalone) {
+ $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
+ } else {
+ \%HTML_2_Latin_1;
+ }
+};
+
+*THITHER = $standalone ? *STDOUT : *STDERR;
+
+my %transfmt = ();
+my $transmo = <<EOFUNC;
+sub transmo {
+ #local \$^W = 0; # recursive warnings we do NOT need!
+ study;
+EOFUNC
+
+my %msg;
+{
+ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
+ local $/ = '';
+ my $header;
+ my $for_item;
+ while (<POD_DIAG>) {
+
+ unescape();
+ if ($PRETTY) {
+ sub noop { return $_[0] } # spensive for a noop
+ sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
+ sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
+ s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
+ s/[LIF]<(.*?)>/italic($1)/ges;
+ } else {
+ s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
+ s/[LIF]<(.*?)>/$1/gs;
+ }
+ unless (/^=/) {
+ if (defined $header) {
+ if ( $header eq 'DESCRIPTION' &&
+ ( /Optional warnings are enabled/
+ || /Some of these messages are generic./
+ ) )
+ {
+ next;
+ }
+ s/^/ /gm;
+ $msg{$header} .= $_;
+ undef $for_item;
+ }
+ next;
+ }
+ unless ( s/=item (.*?)\s*\z//) {
+
+ if ( s/=head1\sDESCRIPTION//) {
+ $msg{$header = 'DESCRIPTION'} = '';
+ undef $for_item;
+ }
+ elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
+ $for_item = $1;
+ }
+ next;
+ }
+
+ if( $for_item ) { $header = $for_item; undef $for_item }
+ else {
+ $header = $1;
+ while( $header =~ /[;,]\z/ ) {
+ <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
+ $header .= ' '.$1;
+ }
+ }
+
+ # strip formatting directives from =item line
+ $header =~ s/[A-Z]<(.*?)>/$1/g;
+
+ my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?[fs])/, $header );
+ if (@toks > 1) {
+ my $conlen = 0;
+ for my $i (0..$#toks){
+ if( $i % 2 ){
+ if( $toks[$i] eq '%c' ){
+ $toks[$i] = '.';
+ } elsif( $toks[$i] eq '%d' ){
+ $toks[$i] = '\d+';
+ } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
+ $toks[$i] = $i == $#toks ? '.*' : '.*?';
+ } elsif( $toks[$i] =~ '%.(\d+)s' ){
+ $toks[$i] = ".{$1}";
+ } elsif( $toks[$i] =~ '^%l*x$' ){
+ $toks[$i] = '[\da-f]+';
+ }
+ } elsif( length( $toks[$i] ) ){
+ $toks[$i] = quotemeta $toks[$i];
+ $conlen += length( $toks[$i] );
+ }
+ }
+ my $lhs = join( '', @toks );
+ $transfmt{$header}{pat} =
+ " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
+ $transfmt{$header}{len} = $conlen;
+ } else {
+ $transfmt{$header}{pat} =
+ " m{^\Q$header\E} && return 1;\n";
+ $transfmt{$header}{len} = length( $header );
+ }
+
+ print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
+ if $msg{$header};
+
+ $msg{$header} = '';
+ }
+
+
+ close POD_DIAG unless *main::DATA eq *POD_DIAG;
+
+ die "No diagnostics?" unless %msg;
+
+ # Apply patterns in order of decreasing sum of lengths of fixed parts
+ # Seems the best way of hitting the right one.
+ for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
+ keys %transfmt ){
+ $transmo .= $transfmt{$hdr}{pat};
+ }
+ $transmo .= " return 0;\n}\n";
+ print STDERR $transmo if $DEBUG;
+ eval $transmo;
+ die $@ if $@;
+}
+
+if ($standalone) {
+ if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
+ while (defined (my $error = <>)) {
+ splainthis($error) || print THITHER $error;
+ }
+ exit;
+}
+
+my $olddie;
+my $oldwarn;
+
+sub import {
+ shift;
+ $^W = 1; # yup, clobbered the global variable;
+ # tough, if you want diags, you want diags.
+ return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
+
+ for (@_) {
+
+ /^-d(ebug)?$/ && do {
+ $DEBUG++;
+ next;
+ };
+
+ /^-v(erbose)?$/ && do {
+ $VERBOSE++;
+ next;
+ };
+
+ /^-p(retty)?$/ && do {
+ print STDERR "$0: I'm afraid it's too late for prettiness.\n";
+ $PRETTY++;
+ next;
+ };
+ # matches trace and traceonly for legacy doc mixup reasons
+ /^-t(race(only)?)?$/ && do {
+ $TRACEONLY++;
+ next;
+ };
+ /^-w(arntrace)?$/ && do {
+ $WARNTRACE++;
+ next;
+ };
+
+ warn "Unknown flag: $_";
+ }
+
+ $oldwarn = $SIG{__WARN__};
+ $olddie = $SIG{__DIE__};
+ $SIG{__WARN__} = \&warn_trap;
+ $SIG{__DIE__} = \&death_trap;
+}
+
+sub enable { &import }
+
+sub disable {
+ shift;
+ return unless $SIG{__WARN__} eq \&warn_trap;
+ $SIG{__WARN__} = $oldwarn || '';
+ $SIG{__DIE__} = $olddie || '';
+}
+
+sub warn_trap {
+ my $warning = $_[0];
+ if (caller eq $WHOAMI or !splainthis($warning)) {
+ if ($WARNTRACE) {
+ print STDERR Carp::longmess($warning);
+ } else {
+ print STDERR $warning;
+ }
+ }
+ goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
+};
+
+sub death_trap {
+ my $exception = $_[0];
+
+ # See if we are coming from anywhere within an eval. If so we don't
+ # want to explain the exception because it's going to get caught.
+ my $in_eval = 0;
+ my $i = 0;
+ while (my $caller = (caller($i++))[3]) {
+ if ($caller eq '(eval)') {
+ $in_eval = 1;
+ last;
+ }
+ }
+
+ splainthis($exception) unless $in_eval;
+ if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
+ &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
+
+ return if $in_eval;
+
+ # We don't want to unset these if we're coming from an eval because
+ # then we've turned off diagnostics.
+
+ # Switch off our die/warn handlers so we don't wind up in our own
+ # traps.
+ $SIG{__DIE__} = $SIG{__WARN__} = '';
+
+ # Have carp skip over death_trap() when showing the stack trace.
+ local($Carp::CarpLevel) = 1;
+
+ confess "Uncaught exception from user code:\n\t$exception";
+ # up we go; where we stop, nobody knows, but i think we die now
+ # but i'm deeply afraid of the &$olddie guy reraising and us getting
+ # into an indirect recursion loop
+};
+
+my %exact_duplicate;
+my %old_diag;
+my $count;
+my $wantspace;
+sub splainthis {
+ return 0 if $TRACEONLY;
+ $_ = shift;
+ local $\;
+ local $!;
+ ### &finish_compilation unless %msg;
+ s/\.?\n+$//;
+ my $orig = $_;
+ # return unless defined;
+
+ # get rid of the where-are-we-in-input part
+ s/, <.*?> (?:line|chunk).*$//;
+
+ # Discard 1st " at <file> line <no>" and all text beyond
+ # but be aware of messsages containing " at this-or-that"
+ my $real = 0;
+ my @secs = split( / at / );
+ return unless @secs;
+ $_ = $secs[0];
+ for my $i ( 1..$#secs ){
+ if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
+ $real = 1;
+ last;
+ } else {
+ $_ .= ' at ' . $secs[$i];
+ }
+ }
+
+ # remove parenthesis occurring at the end of some messages
+ s/^\((.*)\)$/$1/;
+
+ if ($exact_duplicate{$orig}++) {
+ return &transmo;
+ } else {
+ return 0 unless &transmo;
+ }
+
+ $orig = shorten($orig);
+ if ($old_diag{$_}) {
+ autodescribe();
+ print THITHER "$orig (#$old_diag{$_})\n";
+ $wantspace = 1;
+ } else {
+ autodescribe();
+ $old_diag{$_} = ++$count;
+ print THITHER "\n" if $wantspace;
+ $wantspace = 0;
+ print THITHER "$orig (#$old_diag{$_})\n";
+ if ($msg{$_}) {
+ print THITHER $msg{$_};
+ } else {
+ if (0 and $standalone) {
+ print THITHER " **** Error #$old_diag{$_} ",
+ ($real ? "is" : "appears to be"),
+ " an unknown diagnostic message.\n\n";
+ }
+ return 0;
+ }
+ }
+ return 1;
+}
+
+sub autodescribe {
+ if ($VERBOSE and not $count) {
+ print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
+ "\n$msg{DESCRIPTION}\n";
+ }
+}
+
+sub unescape {
+ s {
+ E<
+ ( [A-Za-z]+ )
+ >
+ } {
+ do {
+ exists $HTML_Escapes{$1}
+ ? do { $HTML_Escapes{$1} }
+ : do {
+ warn "Unknown escape: E<$1> in $_";
+ "E<$1>";
+ }
+ }
+ }egx;
+}
+
+sub shorten {
+ my $line = $_[0];
+ if (length($line) > 79 and index($line, "\n") == -1) {
+ my $space_place = rindex($line, ' ', 79);
+ if ($space_place != -1) {
+ substr($line, $space_place, 1) = "\n\t";
+ }
+ }
+ return $line;
+}
+
+
+1 unless $standalone; # or it'll complain about itself
+__END__ # wish diag dbase were more accessible
diff --git a/Master/tlpkg/tlperl/lib/dotsh.pl b/Master/tlpkg/tlperl/lib/dotsh.pl
new file mode 100644
index 00000000000..2ae88ba43de
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/dotsh.pl
@@ -0,0 +1,76 @@
+#
+# @(#)dotsh.pl 03/19/94
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Author: Charles Collins
+#
+# Description:
+# This routine takes a shell script and 'dots' it into the current perl
+# environment. This makes it possible to use existing system scripts
+# to alter environment variables on the fly.
+#
+# Usage:
+# &dotsh ('ShellScript', 'DependentVariable(s)');
+#
+# where
+#
+# 'ShellScript' is the full name of the shell script to be dotted
+#
+# 'DependentVariable(s)' is an optional list of shell variables in the
+# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is
+# dependent upon. These variables MUST be defined using shell syntax.
+#
+# Example:
+# &dotsh ('/foo/bar', 'arg1');
+# &dotsh ('/foo/bar');
+# &dotsh ('/foo/bar arg1 ... argN');
+#
+
+sub dotsh {
+ local(@sh) = @_;
+ local($tmp,$key,$shell,$command,$args,$vars) = '';
+ local(*dotsh);
+ undef *dotsh;
+ $dotsh = shift(@sh);
+ @dotsh = split (/\s/, $dotsh);
+ $command = shift (@dotsh);
+ $args = join (" ", @dotsh);
+ $vars = join ("\n", @sh);
+ open (_SH_ENV, "$command") || die "Could not open $dotsh!\n";
+ chop($_ = <_SH_ENV>);
+ $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/);
+ close (_SH_ENV);
+ if (!$shell) {
+ if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/bash$|\/csh$/) {
+ $shell = "$ENV{'SHELL'} -c";
+ } else {
+ print "SHELL not recognized!\nUsing /bin/sh...\n";
+ $shell = "/bin/sh -c";
+ }
+ }
+ if (length($vars) > 0) {
+ open (_SH_ENV, "$shell \"$vars && . $command $args && set \" |") || die;
+ } else {
+ open (_SH_ENV, "$shell \". $command $args && set \" |") || die;
+ }
+
+ while (<_SH_ENV>) {
+ chop;
+ m/^([^=]*)=(.*)/s;
+ $ENV{$1} = $2;
+ }
+ close (_SH_ENV);
+
+ foreach $key (keys(%ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+ }
+ eval $tmp;
+}
+1;
diff --git a/Master/tlpkg/tlperl/lib/dumpvar.pl b/Master/tlpkg/tlperl/lib/dumpvar.pl
new file mode 100644
index 00000000000..0268cea8bc8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/dumpvar.pl
@@ -0,0 +1,552 @@
+require 5.002; # For (defined ref)
+package dumpvar;
+
+# Needed for PrettyPrinter only:
+
+# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
+
+# translate control chars to ^X - Randal Schwartz
+# Modifications to print types by Peter Gordon v1.0
+
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+
+# Won't dump symbol tables and contents of debugged files by default
+
+$winsize = 80 unless defined $winsize;
+
+
+# Defaults
+
+# $globPrint = 1;
+$printUndef = 1 unless defined $printUndef;
+$tick = "auto" unless defined $tick;
+$unctrl = 'quote' unless defined $unctrl;
+$subdump = 1;
+$dumpReused = 0 unless defined $dumpReused;
+$bareStringify = 1 unless defined $bareStringify;
+
+sub main::dumpValue {
+ local %address;
+ local $^W=0;
+ (print "undef\n"), return unless defined $_[0];
+ (print &stringify($_[0]), "\n"), return unless ref $_[0];
+ push @_, -1 if @_ == 1;
+ dumpvar::unwrap($_[0], 0, $_[1]);
+}
+
+# This one is good for variable names:
+
+sub unctrl {
+ local($_) = @_;
+ local($v) ;
+
+ return \$_ if ref \$_ eq "GLOB";
+ if (ord('A') == 193) { # EBCDIC.
+ # EBCDIC has no concept of "\cA" or "A" being related
+ # to each other by a linear/boolean mapping.
+ } else {
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ }
+ $_;
+}
+
+sub uniescape {
+ join("",
+ map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
+ unpack("U*", $_[0]));
+}
+
+sub stringify {
+ local($_,$noticks) = @_;
+ local($v) ;
+ my $tick = $tick;
+
+ return 'undef' unless defined $_ or not $printUndef;
+ return $_ . "" if ref \$_ eq 'GLOB';
+ $_ = &{'overload::StrVal'}($_)
+ if $bareStringify and ref $_
+ and %overload:: and defined &{'overload::StrVal'};
+
+ if ($tick eq 'auto') {
+ if (ord('A') == 193) {
+ if (/[\000-\011]/ or /[\013-\024\31-\037\177]/) {
+ $tick = '"';
+ } else {
+ $tick = "'";
+ }
+ } else {
+ if (/[\000-\011\013-\037\177]/) {
+ $tick = '"';
+ } else {
+ $tick = "'";
+ }
+ }
+ }
+ if ($tick eq "'") {
+ s/([\'\\])/\\$1/g;
+ } elsif ($unctrl eq 'unctrl') {
+ s/([\"\\])/\\$1/g ;
+ s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ # uniescape?
+ s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
+ if $quoteHighBit;
+ } elsif ($unctrl eq 'quote') {
+ s/([\"\\\$\@])/\\$1/g if $tick eq '"';
+ s/\033/\\e/g;
+ if (ord('A') == 193) { # EBCDIC.
+ s/([\000-\037\177])/'\\c'.chr(193)/eg; # Unfinished.
+ } else {
+ s/([\000-\037\177])/'\\c'._escaped_ord($1)/eg;
+ }
+ }
+ $_ = uniescape($_);
+ s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
+ ($noticks || /^\d+(\.\d*)?\Z/)
+ ? $_
+ : $tick . $_ . $tick;
+}
+
+# Ensure a resulting \ is escaped to be \\
+sub _escaped_ord {
+ my $chr = shift;
+ $chr = chr(ord($chr)^64);
+ $chr =~ s{\\}{\\\\}g;
+ return $chr;
+}
+
+sub ShortArray {
+ my $tArrayDepth = $#{$_[0]} ;
+ $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
+ unless $arrayDepth eq '' ;
+ my $shortmore = "";
+ $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
+ if (!grep(ref $_, @{$_[0]})) {
+ $short = "0..$#{$_[0]} '" .
+ join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
+ return $short if length $short <= $compactDump;
+ }
+ undef;
+}
+
+sub DumpElem {
+ my $short = &stringify($_[0], ref $_[0]);
+ if ($veryCompact && ref $_[0]
+ && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
+ my $end = "0..$#{$v} '" .
+ join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
+ } elsif ($veryCompact && ref $_[0]
+ && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
+ my $end = 1;
+ $short = $sp . "0..$#{$v} '" .
+ join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
+ } else {
+ print "$short\n";
+ unwrap($_[0],$_[1],$_[2]) if ref $_[0];
+ }
+}
+
+sub unwrap {
+ return if $DB::signal;
+ local($v) = shift ;
+ local($s) = shift ; # extra no of spaces
+ local($m) = shift ; # maximum recursion depth
+ return if $m == 0;
+ local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
+ local($tHashDepth,$tArrayDepth) ;
+
+ $sp = " " x $s ;
+ $s += 3 ;
+
+ # Check for reused addresses
+ if (ref $v) {
+ my $val = $v;
+ $val = &{'overload::StrVal'}($v)
+ if %overload:: and defined &{'overload::StrVal'};
+ # Match type and address.
+ # Unblessed references will look like TYPE(0x...)
+ # Blessed references will look like Class=TYPE(0x...)
+ ($start_part, $val) = split /=/,$val;
+ $val = $start_part unless defined $val;
+ ($item_type, $address) =
+ $val =~ /([^\(]+) # Keep stuff that's
+ # not an open paren
+ \( # Skip open paren
+ (0x[0-9a-f]+) # Save the address
+ \) # Skip close paren
+ $/x; # Should be at end now
+
+ if (!$dumpReused && defined $address) {
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}-> REUSED_ADDRESS\n" ;
+ return ;
+ }
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ # This is a raw glob. Special handling for that.
+ $address = "$v" . ""; # To avoid a bug with globs
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}*DUMPED_GLOB*\n" ;
+ return ;
+ }
+ }
+
+ if (ref $v eq 'Regexp') {
+ # Reformat the regexp to look the standard way.
+ my $re = "$v";
+ $re =~ s,/,\\/,g;
+ print "$sp-> qr/$re/\n";
+ return;
+ }
+
+ if ( $item_type eq 'HASH' ) {
+ # Hash ref or hash-based object.
+ my @sortKeys = sort keys(%$v) ;
+ undef $more ;
+ $tHashDepth = $#sortKeys ;
+ $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
+ unless $hashDepth eq '' ;
+ $more = "....\n" if $tHashDepth < $#sortKeys ;
+ $shortmore = "";
+ $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
+ $#sortKeys = $tHashDepth ;
+ if ($compactDump && !grep(ref $_, values %{$v})) {
+ #$short = $sp .
+ # (join ', ',
+# Next row core dumps during require from DB on 5.000, even with map {"_"}
+ # map {&stringify($_) . " => " . &stringify($v->{$_})}
+ # @sortKeys) . "'$shortmore";
+ $short = $sp;
+ my @keys;
+ for (@sortKeys) {
+ push @keys, &stringify($_) . " => " . &stringify($v->{$_});
+ }
+ $short .= join ', ', @keys;
+ $short .= $shortmore;
+ (print "$short\n"), return if length $short <= $compactDump;
+ }
+ for $key (@sortKeys) {
+ return if $DB::signal;
+ $value = $ {$v}{$key} ;
+ print "$sp", &stringify($key), " => ";
+ DumpElem $value, $s, $m-1;
+ }
+ print "$sp empty hash\n" unless @sortKeys;
+ print "$sp$more" if defined $more ;
+ } elsif ( $item_type eq 'ARRAY' ) {
+ # Array ref or array-based object. Also: undef.
+ # See how big the array is.
+ $tArrayDepth = $#{$v} ;
+ undef $more ;
+ # Bigger than the max?
+ $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
+ if defined $arrayDepth && $arrayDepth ne '';
+ # Yep. Don't show it all.
+ $more = "....\n" if $tArrayDepth < $#{$v} ;
+ $shortmore = "";
+ $shortmore = " ..." if $tArrayDepth < $#{$v} ;
+
+ if ($compactDump && !grep(ref $_, @{$v})) {
+ if ($#$v >= 0) {
+ $short = $sp . "0..$#{$v} " .
+ join(" ",
+ map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth)
+ ) . "$shortmore";
+ } else {
+ $short = $sp . "empty array";
+ }
+ (print "$short\n"), return if length $short <= $compactDump;
+ }
+ #if ($compactDump && $short = ShortArray($v)) {
+ # print "$short\n";
+ # return;
+ #}
+ for $num ($[ .. $tArrayDepth) {
+ return if $DB::signal;
+ print "$sp$num ";
+ if (exists $v->[$num]) {
+ if (defined $v->[$num]) {
+ DumpElem $v->[$num], $s, $m-1;
+ }
+ else {
+ print "undef\n";
+ }
+ } else {
+ print "empty slot\n";
+ }
+ }
+ print "$sp empty array\n" unless @$v;
+ print "$sp$more" if defined $more ;
+ } elsif ( $item_type eq 'SCALAR' ) {
+ unless (defined $$v) {
+ print "$sp-> undef\n";
+ return;
+ }
+ print "$sp-> ";
+ DumpElem $$v, $s, $m-1;
+ } elsif ( $item_type eq 'REF' ) {
+ print "$sp-> $$v\n";
+ return unless defined $$v;
+ unwrap($$v, $s+3, $m-1);
+ } elsif ( $item_type eq 'CODE' ) {
+ # Code object or reference.
+ print "$sp-> ";
+ dumpsub (0, $v);
+ } elsif ( $item_type eq 'GLOB' ) {
+ # Glob object or reference.
+ print "$sp-> ",&stringify($$v,1),"\n";
+ if ($globPrint) {
+ $s += 3;
+ dumpglob($s, "{$$v}", $$v, 1, $m-1);
+ } elsif (defined ($fileno = eval {fileno($v)})) {
+ print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ # Raw glob (again?)
+ if ($globPrint) {
+ dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;
+ } elsif (defined ($fileno = eval {fileno(\$v)})) {
+ print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
+ }
+ }
+}
+
+sub matchlex {
+ (my $var = $_[0]) =~ s/.//;
+ $var eq $_[1] or
+ ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
+ ($1 eq '!') ^ (eval { $var =~ /$2$3/ });
+}
+
+sub matchvar {
+ $_[0] eq $_[1] or
+ ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
+ ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
+}
+
+sub compactDump {
+ $compactDump = shift if @_;
+ $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
+ $compactDump;
+}
+
+sub veryCompact {
+ $veryCompact = shift if @_;
+ compactDump(1) if !$compactDump and $veryCompact;
+ $veryCompact;
+}
+
+sub unctrlSet {
+ if (@_) {
+ my $in = shift;
+ if ($in eq 'unctrl' or $in eq 'quote') {
+ $unctrl = $in;
+ } else {
+ print "Unknown value for `unctrl'.\n";
+ }
+ }
+ $unctrl;
+}
+
+sub quote {
+ if (@_ and $_[0] eq '"') {
+ $tick = '"';
+ $unctrl = 'quote';
+ } elsif (@_ and $_[0] eq 'auto') {
+ $tick = 'auto';
+ $unctrl = 'quote';
+ } elsif (@_) { # Need to set
+ $tick = "'";
+ $unctrl = 'unctrl';
+ }
+ $tick;
+}
+
+sub dumpglob {
+ return if $DB::signal;
+ my ($off,$key, $val, $all, $m) = @_;
+ local(*entry) = $val;
+ my $fileno;
+ if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
+ print( (' ' x $off) . "\$", &unctrl($key), " = " );
+ DumpElem $entry, 3+$off, $m;
+ }
+ if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
+ print( (' ' x $off) . "\@$key = (\n" );
+ unwrap(\@entry,3+$off,$m) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if ($key ne "main::" && $key ne "DB::" && %entry
+ && ($dumpPackages or $key !~ /::$/)
+ && ($key !~ /^_</ or $dumpDBFiles)
+ && !($package eq "dumpvar" and $key eq "stab")) {
+ print( (' ' x $off) . "\%$key = (\n" );
+ unwrap(\%entry,3+$off,$m) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if (defined ($fileno = eval{fileno(*entry)})) {
+ print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
+ }
+ if ($all) {
+ if (defined &entry) {
+ dumpsub($off, $key);
+ }
+ }
+}
+
+sub dumplex {
+ return if $DB::signal;
+ my ($key, $val, $m, @vars) = @_;
+ return if @vars && !grep( matchlex($key, $_), @vars );
+ local %address;
+ my $off = 0; # It reads better this way
+ my $fileno;
+ if (UNIVERSAL::isa($val,'ARRAY')) {
+ print( (' ' x $off) . "$key = (\n" );
+ unwrap($val,3+$off,$m) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ elsif (UNIVERSAL::isa($val,'HASH')) {
+ print( (' ' x $off) . "$key = (\n" );
+ unwrap($val,3+$off,$m) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ elsif (UNIVERSAL::isa($val,'IO')) {
+ print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
+ }
+ # No lexical subroutines yet...
+ # elsif (UNIVERSAL::isa($val,'CODE')) {
+ # dumpsub($off, $$val);
+ # }
+ else {
+ print( (' ' x $off) . &unctrl($key), " = " );
+ DumpElem $$val, 3+$off, $m;
+ }
+}
+
+sub CvGV_name_or_bust {
+ my $in = shift;
+ return if $skipCvGV; # Backdoor to avoid problems if XS broken...
+ $in = \&$in; # Hard reference...
+ eval {require Devel::Peek; 1} or return;
+ my $gv = Devel::Peek::CvGV($in) or return;
+ *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
+sub dumpsub {
+ my ($off,$sub) = @_;
+ my $ini = $sub;
+ my $s;
+ $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
+ my $subref = defined $1 ? \&$sub : \&$ini;
+ my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+ || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
+ || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
+ $place = '???' unless defined $place;
+ $s = $sub unless defined $s;
+ print( (' ' x $off) . "&$s in $place\n" );
+}
+
+sub findsubs {
+ return undef unless %DB::sub;
+ my ($addr, $name, $loc);
+ while (($name, $loc) = each %DB::sub) {
+ $addr = \&$name;
+ $subs{"$addr"} = $name;
+ }
+ $subdump = 0;
+ $subs{ shift() };
+}
+
+sub main::dumpvar {
+ my ($package,$m,@vars) = @_;
+ local(%address,$key,$val,$^W);
+ $package .= "::" unless $package =~ /::$/;
+ *stab = *{"main::"};
+ while ($package =~ /(\w+?::)/g){
+ *stab = $ {stab}{$1};
+ }
+ local $TotalStrings = 0;
+ local $Strings = 0;
+ local $CompleteTotal = 0;
+ while (($key,$val) = each(%stab)) {
+ return if $DB::signal;
+ next if @vars && !grep( matchvar($key, $_), @vars );
+ if ($usageOnly) {
+ globUsage(\$val, $key)
+ if ($package ne 'dumpvar' or $key ne 'stab')
+ and ref(\$val) eq 'GLOB';
+ } else {
+ dumpglob(0,$key, $val, 0, $m);
+ }
+ }
+ if ($usageOnly) {
+ print "String space: $TotalStrings bytes in $Strings strings.\n";
+ $CompleteTotal += $TotalStrings;
+ print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
+ }
+}
+
+sub scalarUsage {
+ my $size = length($_[0]);
+ $TotalStrings += $size;
+ $Strings++;
+ $size;
+}
+
+sub arrayUsage { # array ref, name
+ my $size = 0;
+ map {$size += scalarUsage($_)} @{$_[0]};
+ my $len = @{$_[0]};
+ print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
+ " (data: $size bytes)\n"
+ if defined $_[1];
+ $CompleteTotal += $size;
+ $size;
+}
+
+sub hashUsage { # hash ref, name
+ my @keys = keys %{$_[0]};
+ my @values = values %{$_[0]};
+ my $keys = arrayUsage \@keys;
+ my $values = arrayUsage \@values;
+ my $len = @keys;
+ my $total = $keys + $values;
+ print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
+ " (keys: $keys; values: $values; total: $total bytes)\n"
+ if defined $_[1];
+ $total;
+}
+
+sub globUsage { # glob ref, name
+ local *name = *{$_[0]};
+ $total = 0;
+ $total += scalarUsage $name if defined $name;
+ $total += arrayUsage \@name, $_[1] if @name;
+ $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::"
+ and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
+ $total;
+}
+
+sub packageUsage {
+ my ($package,@vars) = @_;
+ $package .= "::" unless $package =~ /::$/;
+ local *stab = *{"main::"};
+ while ($package =~ /(\w+?::)/g){
+ *stab = $ {stab}{$1};
+ }
+ local $TotalStrings = 0;
+ local $CompleteTotal = 0;
+ my ($key,$val);
+ while (($key,$val) = each(%stab)) {
+ next if @vars && !grep($key eq $_,@vars);
+ globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
+ }
+ print "String space: $TotalStrings.\n";
+ $CompleteTotal += $TotalStrings;
+ print "\nGrand total = $CompleteTotal bytes\n";
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/encoding.pm b/Master/tlpkg/tlperl/lib/encoding.pm
new file mode 100644
index 00000000000..be20a494487
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/encoding.pm
@@ -0,0 +1,669 @@
+# $Id: encoding.pm,v 2.8 2009/02/15 17:44:13 dankogai Exp $
+package encoding;
+our $VERSION = '2.6_01';
+
+use Encode;
+use strict;
+use warnings;
+
+sub DEBUG () { 0 }
+
+BEGIN {
+ if ( ord("A") == 193 ) {
+ require Carp;
+ Carp::croak("encoding: pragma does not support EBCDIC platforms");
+ }
+}
+
+our $HAS_PERLIO = 0;
+eval { require PerlIO::encoding };
+unless ($@) {
+ $HAS_PERLIO = ( PerlIO::encoding->VERSION >= 0.02 );
+}
+
+sub _exception {
+ my $name = shift;
+ $] > 5.008 and return 0; # 5.8.1 or higher then no
+ my %utfs = map { $_ => 1 }
+ qw(utf8 UCS-2BE UCS-2LE UTF-16 UTF-16BE UTF-16LE
+ UTF-32 UTF-32BE UTF-32LE);
+ $utfs{$name} or return 0; # UTFs or no
+ require Config;
+ Config->import();
+ our %Config;
+ return $Config{perl_patchlevel} ? 0 : 1 # maintperl then no
+}
+
+sub in_locale { $^H & ( $locale::hint_bits || 0 ) }
+
+sub _get_locale_encoding {
+ my $locale_encoding;
+
+ # I18N::Langinfo isn't available everywhere
+ eval {
+ require I18N::Langinfo;
+ I18N::Langinfo->import(qw(langinfo CODESET));
+ $locale_encoding = langinfo( CODESET() );
+ };
+
+ my $country_language;
+
+ no warnings 'uninitialized';
+
+ if ( (not $locale_encoding) && in_locale() ) {
+ if ( $ENV{LC_ALL} =~ /^([^.]+)\.([^.@]+)(@.*)?$/ ) {
+ ( $country_language, $locale_encoding ) = ( $1, $2 );
+ }
+ elsif ( $ENV{LANG} =~ /^([^.]+)\.([^.@]+)(@.*)?$/ ) {
+ ( $country_language, $locale_encoding ) = ( $1, $2 );
+ }
+
+ # LANGUAGE affects only LC_MESSAGES only on glibc
+ }
+ elsif ( not $locale_encoding ) {
+ if ( $ENV{LC_ALL} =~ /\butf-?8\b/i
+ || $ENV{LANG} =~ /\butf-?8\b/i )
+ {
+ $locale_encoding = 'utf8';
+ }
+
+ # Could do more heuristics based on the country and language
+ # parts of LC_ALL and LANG (the parts before the dot (if any)),
+ # since we have Locale::Country and Locale::Language available.
+ # TODO: get a database of Language -> Encoding mappings
+ # (the Estonian database at http://www.eki.ee/letter/
+ # would be excellent!) --jhi
+ }
+ if ( defined $locale_encoding
+ && lc($locale_encoding) eq 'euc'
+ && defined $country_language )
+ {
+ if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
+ $locale_encoding = 'euc-jp';
+ }
+ elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
+ $locale_encoding = 'euc-kr';
+ }
+ elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)$/i ) {
+ $locale_encoding = 'euc-cn';
+ }
+ elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
+ $locale_encoding = 'euc-tw';
+ }
+ else {
+ require Carp;
+ Carp::croak(
+ "encoding: Locale encoding '$locale_encoding' too ambiguous"
+ );
+ }
+ }
+
+ return $locale_encoding;
+}
+
+sub import {
+ my $class = shift;
+ my $name = shift;
+ if ( $name eq ':_get_locale_encoding' ) { # used by lib/open.pm
+ my $caller = caller();
+ {
+ no strict 'refs';
+ *{"${caller}::_get_locale_encoding"} = \&_get_locale_encoding;
+ }
+ return;
+ }
+ $name = _get_locale_encoding() if $name eq ':locale';
+ my %arg = @_;
+ $name = $ENV{PERL_ENCODING} unless defined $name;
+ my $enc = find_encoding($name);
+ unless ( defined $enc ) {
+ require Carp;
+ Carp::croak("encoding: Unknown encoding '$name'");
+ }
+ $name = $enc->name; # canonize
+ unless ( $arg{Filter} ) {
+ DEBUG and warn "_exception($name) = ", _exception($name);
+ _exception($name) or ${^ENCODING} = $enc;
+ $HAS_PERLIO or return 1;
+ }
+ else {
+ defined( ${^ENCODING} ) and undef ${^ENCODING};
+
+ # implicitly 'use utf8'
+ require utf8; # to fetch $utf8::hint_bits;
+ $^H |= $utf8::hint_bits;
+ eval {
+ require Filter::Util::Call;
+ Filter::Util::Call->import;
+ filter_add(
+ sub {
+ my $status = filter_read();
+ if ( $status > 0 ) {
+ $_ = $enc->decode( $_, 1 );
+ DEBUG and warn $_;
+ }
+ $status;
+ }
+ );
+ };
+ $@ eq '' and DEBUG and warn "Filter installed";
+ }
+ defined ${^UNICODE} and ${^UNICODE} != 0 and return 1;
+ for my $h (qw(STDIN STDOUT)) {
+ if ( $arg{$h} ) {
+ unless ( defined find_encoding( $arg{$h} ) ) {
+ require Carp;
+ Carp::croak(
+ "encoding: Unknown encoding for $h, '$arg{$h}'");
+ }
+ eval { binmode( $h, ":raw :encoding($arg{$h})" ) };
+ }
+ else {
+ unless ( exists $arg{$h} ) {
+ eval {
+ no warnings 'uninitialized';
+ binmode( $h, ":raw :encoding($name)" );
+ };
+ }
+ }
+ if ($@) {
+ require Carp;
+ Carp::croak($@);
+ }
+ }
+ return 1; # I doubt if we need it, though
+}
+
+sub unimport {
+ no warnings;
+ undef ${^ENCODING};
+ if ($HAS_PERLIO) {
+ binmode( STDIN, ":raw" );
+ binmode( STDOUT, ":raw" );
+ }
+ else {
+ binmode(STDIN);
+ binmode(STDOUT);
+ }
+ if ( $INC{"Filter/Util/Call.pm"} ) {
+ eval { filter_del() };
+ }
+}
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+encoding - allows you to write your script in non-ascii or non-utf8
+
+=head1 SYNOPSIS
+
+ use encoding "greek"; # Perl like Greek to you?
+ use encoding "euc-jp"; # Jperl!
+
+ # or you can even do this if your shell supports your native encoding
+
+ perl -Mencoding=latin2 -e'...' # Feeling centrally European?
+ perl -Mencoding=euc-kr -e'...' # Or Korean?
+
+ # more control
+
+ # A simple euc-cn => utf-8 converter
+ use encoding "euc-cn", STDOUT => "utf8"; while(<>){print};
+
+ # "no encoding;" supported (but not scoped!)
+ no encoding;
+
+ # an alternate way, Filter
+ use encoding "euc-jp", Filter=>1;
+ # now you can use kanji identifiers -- in euc-jp!
+
+ # switch on locale -
+ # note that this probably means that unless you have a complete control
+ # over the environments the application is ever going to be run, you should
+ # NOT use the feature of encoding pragma allowing you to write your script
+ # in any recognized encoding because changing locale settings will wreck
+ # the script; you can of course still use the other features of the pragma.
+ use encoding ':locale';
+
+=head1 ABSTRACT
+
+Let's start with a bit of history: Perl 5.6.0 introduced Unicode
+support. You could apply C<substr()> and regexes even to complex CJK
+characters -- so long as the script was written in UTF-8. But back
+then, text editors that supported UTF-8 were still rare and many users
+instead chose to write scripts in legacy encodings, giving up a whole
+new feature of Perl 5.6.
+
+Rewind to the future: starting from perl 5.8.0 with the B<encoding>
+pragma, you can write your script in any encoding you like (so long
+as the C<Encode> module supports it) and still enjoy Unicode support.
+This pragma achieves that by doing the following:
+
+=over
+
+=item *
+
+Internally converts all literals (C<q//,qq//,qr//,qw///, qx//>) from
+the encoding specified to utf8. In Perl 5.8.1 and later, literals in
+C<tr///> and C<DATA> pseudo-filehandle are also converted.
+
+=item *
+
+Changing PerlIO layers of C<STDIN> and C<STDOUT> to the encoding
+ specified.
+
+=back
+
+=head2 Literal Conversions
+
+You can write code in EUC-JP as follows:
+
+ my $Rakuda = "\xF1\xD1\xF1\xCC"; # Camel in Kanji
+ #<-char-><-char-> # 4 octets
+ s/\bCamel\b/$Rakuda/;
+
+And with C<use encoding "euc-jp"> in effect, it is the same thing as
+the code in UTF-8:
+
+ my $Rakuda = "\x{99F1}\x{99DD}"; # two Unicode Characters
+ s/\bCamel\b/$Rakuda/;
+
+=head2 PerlIO layers for C<STD(IN|OUT)>
+
+The B<encoding> pragma also modifies the filehandle layers of
+STDIN and STDOUT to the specified encoding. Therefore,
+
+ use encoding "euc-jp";
+ my $message = "Camel is the symbol of perl.\n";
+ my $Rakuda = "\xF1\xD1\xF1\xCC"; # Camel in Kanji
+ $message =~ s/\bCamel\b/$Rakuda/;
+ print $message;
+
+Will print "\xF1\xD1\xF1\xCC is the symbol of perl.\n",
+not "\x{99F1}\x{99DD} is the symbol of perl.\n".
+
+You can override this by giving extra arguments; see below.
+
+=head2 Implicit upgrading for byte strings
+
+By default, if strings operating under byte semantics and strings
+with Unicode character data are concatenated, the new string will
+be created by decoding the byte strings as I<ISO 8859-1 (Latin-1)>.
+
+The B<encoding> pragma changes this to use the specified encoding
+instead. For example:
+
+ use encoding 'utf8';
+ my $string = chr(20000); # a Unicode string
+ utf8::encode($string); # now it's a UTF-8 encoded byte string
+ # concatenate with another Unicode string
+ print length($string . chr(20000));
+
+Will print C<2>, because C<$string> is upgraded as UTF-8. Without
+C<use encoding 'utf8';>, it will print C<4> instead, since C<$string>
+is three octets when interpreted as Latin-1.
+
+=head2 Side effects
+
+If the C<encoding> pragma is in scope then the lengths returned are
+calculated from the length of C<$/> in Unicode characters, which is not
+always the same as the length of C<$/> in the native encoding.
+
+This pragma affects utf8::upgrade, but not utf8::downgrade.
+
+=head1 FEATURES THAT REQUIRE 5.8.1
+
+Some of the features offered by this pragma requires perl 5.8.1. Most
+of these are done by Inaba Hiroto. Any other features and changes
+are good for 5.8.0.
+
+=over
+
+=item "NON-EUC" doublebyte encodings
+
+Because perl needs to parse script before applying this pragma, such
+encodings as Shift_JIS and Big-5 that may contain '\' (BACKSLASH;
+\x5c) in the second byte fails because the second byte may
+accidentally escape the quoting character that follows. Perl 5.8.1
+or later fixes this problem.
+
+=item tr//
+
+C<tr//> was overlooked by Perl 5 porters when they released perl 5.8.0
+See the section below for details.
+
+=item DATA pseudo-filehandle
+
+Another feature that was overlooked was C<DATA>.
+
+=back
+
+=head1 USAGE
+
+=over 4
+
+=item use encoding [I<ENCNAME>] ;
+
+Sets the script encoding to I<ENCNAME>. And unless ${^UNICODE}
+exists and non-zero, PerlIO layers of STDIN and STDOUT are set to
+":encoding(I<ENCNAME>)".
+
+Note that STDERR WILL NOT be changed.
+
+Also note that non-STD file handles remain unaffected. Use C<use
+open> or C<binmode> to change layers of those.
+
+If no encoding is specified, the environment variable L<PERL_ENCODING>
+is consulted. If no encoding can be found, the error C<Unknown encoding
+'I<ENCNAME>'> will be thrown.
+
+=item use encoding I<ENCNAME> [ STDIN =E<gt> I<ENCNAME_IN> ...] ;
+
+You can also individually set encodings of STDIN and STDOUT via the
+C<< STDIN => I<ENCNAME> >> form. In this case, you cannot omit the
+first I<ENCNAME>. C<< STDIN => undef >> turns the IO transcoding
+completely off.
+
+When ${^UNICODE} exists and non-zero, these options will completely
+ignored. ${^UNICODE} is a variable introduced in perl 5.8.1. See
+L<perlrun> see L<perlvar/"${^UNICODE}"> and L<perlrun/"-C"> for
+details (perl 5.8.1 and later).
+
+=item use encoding I<ENCNAME> Filter=E<gt>1;
+
+This turns the encoding pragma into a source filter. While the
+default approach just decodes interpolated literals (in qq() and
+qr()), this will apply a source filter to the entire source code. See
+L</"The Filter Option"> below for details.
+
+=item no encoding;
+
+Unsets the script encoding. The layers of STDIN, STDOUT are
+reset to ":raw" (the default unprocessed raw stream of bytes).
+
+=back
+
+=head1 The Filter Option
+
+The magic of C<use encoding> is not applied to the names of
+identifiers. In order to make C<${"\x{4eba}"}++> ($human++, where human
+is a single Han ideograph) work, you still need to write your script
+in UTF-8 -- or use a source filter. That's what 'Filter=>1' does.
+
+What does this mean? Your source code behaves as if it is written in
+UTF-8 with 'use utf8' in effect. So even if your editor only supports
+Shift_JIS, for example, you can still try examples in Chapter 15 of
+C<Programming Perl, 3rd Ed.>. For instance, you can use UTF-8
+identifiers.
+
+This option is significantly slower and (as of this writing) non-ASCII
+identifiers are not very stable WITHOUT this option and with the
+source code written in UTF-8.
+
+=head2 Filter-related changes at Encode version 1.87
+
+=over
+
+=item *
+
+The Filter option now sets STDIN and STDOUT like non-filter options.
+And C<< STDIN=>I<ENCODING> >> and C<< STDOUT=>I<ENCODING> >> work like
+non-filter version.
+
+=item *
+
+C<use utf8> is implicitly declared so you no longer have to C<use
+utf8> to C<${"\x{4eba}"}++>.
+
+=back
+
+=head1 CAVEATS
+
+=head2 NOT SCOPED
+
+The pragma is a per script, not a per block lexical. Only the last
+C<use encoding> or C<no encoding> matters, and it affects
+B<the whole script>. However, the <no encoding> pragma is supported and
+B<use encoding> can appear as many times as you want in a given script.
+The multiple use of this pragma is discouraged.
+
+By the same reason, the use this pragma inside modules is also
+discouraged (though not as strongly discouraged as the case above.
+See below).
+
+If you still have to write a module with this pragma, be very careful
+of the load order. See the codes below;
+
+ # called module
+ package Module_IN_BAR;
+ use encoding "bar";
+ # stuff in "bar" encoding here
+ 1;
+
+ # caller script
+ use encoding "foo"
+ use Module_IN_BAR;
+ # surprise! use encoding "bar" is in effect.
+
+The best way to avoid this oddity is to use this pragma RIGHT AFTER
+other modules are loaded. i.e.
+
+ use Module_IN_BAR;
+ use encoding "foo";
+
+=head2 DO NOT MIX MULTIPLE ENCODINGS
+
+Notice that only literals (string or regular expression) having only
+legacy code points are affected: if you mix data like this
+
+ \xDF\x{100}
+
+the data is assumed to be in (Latin 1 and) Unicode, not in your native
+encoding. In other words, this will match in "greek":
+
+ "\xDF" =~ /\x{3af}/
+
+but this will not
+
+ "\xDF\x{100}" =~ /\x{3af}\x{100}/
+
+since the C<\xDF> (ISO 8859-7 GREEK SMALL LETTER IOTA WITH TONOS) on
+the left will B<not> be upgraded to C<\x{3af}> (Unicode GREEK SMALL
+LETTER IOTA WITH TONOS) because of the C<\x{100}> on the left. You
+should not be mixing your legacy data and Unicode in the same string.
+
+This pragma also affects encoding of the 0x80..0xFF code point range:
+normally characters in that range are left as eight-bit bytes (unless
+they are combined with characters with code points 0x100 or larger,
+in which case all characters need to become UTF-8 encoded), but if
+the C<encoding> pragma is present, even the 0x80..0xFF range always
+gets UTF-8 encoded.
+
+After all, the best thing about this pragma is that you don't have to
+resort to \x{....} just to spell your name in a native encoding.
+So feel free to put your strings in your encoding in quotes and
+regexes.
+
+=head2 tr/// with ranges
+
+The B<encoding> pragma works by decoding string literals in
+C<q//,qq//,qr//,qw///, qx//> and so forth. In perl 5.8.0, this
+does not apply to C<tr///>. Therefore,
+
+ use encoding 'euc-jp';
+ #....
+ $kana =~ tr/\xA4\xA1-\xA4\xF3/\xA5\xA1-\xA5\xF3/;
+ # -------- -------- -------- --------
+
+Does not work as
+
+ $kana =~ tr/\x{3041}-\x{3093}/\x{30a1}-\x{30f3}/;
+
+=over
+
+=item Legend of characters above
+
+ utf8 euc-jp charnames::viacode()
+ -----------------------------------------
+ \x{3041} \xA4\xA1 HIRAGANA LETTER SMALL A
+ \x{3093} \xA4\xF3 HIRAGANA LETTER N
+ \x{30a1} \xA5\xA1 KATAKANA LETTER SMALL A
+ \x{30f3} \xA5\xF3 KATAKANA LETTER N
+
+=back
+
+This counterintuitive behavior has been fixed in perl 5.8.1.
+
+=head3 workaround to tr///;
+
+In perl 5.8.0, you can work around as follows;
+
+ use encoding 'euc-jp';
+ # ....
+ eval qq{ \$kana =~ tr/\xA4\xA1-\xA4\xF3/\xA5\xA1-\xA5\xF3/ };
+
+Note the C<tr//> expression is surrounded by C<qq{}>. The idea behind
+is the same as classic idiom that makes C<tr///> 'interpolate'.
+
+ tr/$from/$to/; # wrong!
+ eval qq{ tr/$from/$to/ }; # workaround.
+
+Nevertheless, in case of B<encoding> pragma even C<q//> is affected so
+C<tr///> not being decoded was obviously against the will of Perl5
+Porters so it has been fixed in Perl 5.8.1 or later.
+
+=head1 EXAMPLE - Greekperl
+
+ use encoding "iso 8859-7";
+
+ # \xDF in ISO 8859-7 (Greek) is \x{3af} in Unicode.
+
+ $a = "\xDF";
+ $b = "\x{100}";
+
+ printf "%#x\n", ord($a); # will print 0x3af, not 0xdf
+
+ $c = $a . $b;
+
+ # $c will be "\x{3af}\x{100}", not "\x{df}\x{100}".
+
+ # chr() is affected, and ...
+
+ print "mega\n" if ord(chr(0xdf)) == 0x3af;
+
+ # ... ord() is affected by the encoding pragma ...
+
+ print "tera\n" if ord(pack("C", 0xdf)) == 0x3af;
+
+ # ... as are eq and cmp ...
+
+ print "peta\n" if "\x{3af}" eq pack("C", 0xdf);
+ print "exa\n" if "\x{3af}" cmp pack("C", 0xdf) == 0;
+
+ # ... but pack/unpack C are not affected, in case you still
+ # want to go back to your native encoding
+
+ print "zetta\n" if unpack("C", (pack("C", 0xdf))) == 0xdf;
+
+=head1 KNOWN PROBLEMS
+
+=over
+
+=item literals in regex that are longer than 127 bytes
+
+For native multibyte encodings (either fixed or variable length),
+the current implementation of the regular expressions may introduce
+recoding errors for regular expression literals longer than 127 bytes.
+
+=item EBCDIC
+
+The encoding pragma is not supported on EBCDIC platforms.
+(Porters who are willing and able to remove this limitation are
+welcome.)
+
+=item format
+
+This pragma doesn't work well with format because PerlIO does not
+get along very well with it. When format contains non-ascii
+characters it prints funny or gets "wide character warnings".
+To understand it, try the code below.
+
+ # Save this one in utf8
+ # replace *non-ascii* with a non-ascii string
+ my $camel;
+ format STDOUT =
+ *non-ascii*@>>>>>>>
+ $camel
+ .
+ $camel = "*non-ascii*";
+ binmode(STDOUT=>':encoding(utf8)'); # bang!
+ write; # funny
+ print $camel, "\n"; # fine
+
+Without binmode this happens to work but without binmode, print()
+fails instead of write().
+
+At any rate, the very use of format is questionable when it comes to
+unicode characters since you have to consider such things as character
+width (i.e. double-width for ideographs) and directions (i.e. BIDI for
+Arabic and Hebrew).
+
+=item Thread safety
+
+C<use encoding ...> is not thread-safe (i.e., do not use in threaded
+applications).
+
+=back
+
+=head2 The Logic of :locale
+
+The logic of C<:locale> is as follows:
+
+=over 4
+
+=item 1.
+
+If the platform supports the langinfo(CODESET) interface, the codeset
+returned is used as the default encoding for the open pragma.
+
+=item 2.
+
+If 1. didn't work but we are under the locale pragma, the environment
+variables LC_ALL and LANG (in that order) are matched for encodings
+(the part after C<.>, if any), and if any found, that is used
+as the default encoding for the open pragma.
+
+=item 3.
+
+If 1. and 2. didn't work, the environment variables LC_ALL and LANG
+(in that order) are matched for anything looking like UTF-8, and if
+any found, C<:utf8> is used as the default encoding for the open
+pragma.
+
+=back
+
+If your locale environment variables (LC_ALL, LC_CTYPE, LANG)
+contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching),
+the default encoding of your STDIN, STDOUT, and STDERR, and of
+B<any subsequent file open>, is UTF-8.
+
+=head1 HISTORY
+
+This pragma first appeared in Perl 5.8.0. For features that require
+5.8.1 and better, see above.
+
+The C<:locale> subpragma was implemented in 2.01, or Perl 5.8.6.
+
+=head1 SEE ALSO
+
+L<perlunicode>, L<Encode>, L<open>, L<Filter::Util::Call>,
+
+Ch. 15 of C<Programming Perl (3rd Edition)>
+by Larry Wall, Tom Christiansen, Jon Orwant;
+O'Reilly & Associates; ISBN 0-596-00027-8
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/exceptions.pl b/Master/tlpkg/tlperl/lib/exceptions.pl
new file mode 100644
index 00000000000..09a4d3e7ae1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/exceptions.pl
@@ -0,0 +1,62 @@
+# exceptions.pl
+# tchrist@convex.com
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+
+# Here's a little code I use for exception handling. It's really just
+# glorfied eval/die. The way to use use it is when you might otherwise
+# exit, use &throw to raise an exception. The first enclosing &catch
+# handler looks at the exception and decides whether it can catch this kind
+# (catch takes a list of regexps to catch), and if so, it returns the one it
+# caught. If it *can't* catch it, then it will reraise the exception
+# for someone else to possibly see, or to die otherwise.
+#
+# I use oddly named variables in order to make darn sure I don't conflict
+# with my caller. I also hide in my own package, and eval the code in his.
+#
+# The EXCEPTION: prefix is so you can tell whether it's a user-raised
+# exception or a perl-raised one (eval error).
+#
+# --tom
+#
+# examples:
+# if (&catch('/$user_input/', 'regexp', 'syntax error') {
+# warn "oops try again";
+# redo;
+# }
+#
+# if ($error = &catch('&subroutine()')) { # catches anything
+#
+# &throw('bad input') if /^$/;
+
+sub catch {
+ package exception;
+ local($__code__, @__exceptions__) = @_;
+ local($__package__) = caller;
+ local($__exception__);
+
+ eval "package $__package__; $__code__";
+ if ($__exception__ = &'thrown) {
+ for (@__exceptions__) {
+ return $__exception__ if /$__exception__/;
+ }
+ &'throw($__exception__);
+ }
+}
+
+sub throw {
+ local($exception) = @_;
+ die "EXCEPTION: $exception\n";
+}
+
+sub thrown {
+ $@ =~ /^(EXCEPTION: )+(.+)/ && $2;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/fastcwd.pl b/Master/tlpkg/tlperl/lib/fastcwd.pl
new file mode 100644
index 00000000000..34b60f71a08
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/fastcwd.pl
@@ -0,0 +1,45 @@
+# By John Bazik
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Cwd
+
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd {
+ local($odev, $oino, $cdev, $cino, $tdev, $tino);
+ local(@path, $path);
+ local(*DIR);
+
+ ($cdev, $cino) = stat('.');
+ for (;;) {
+ ($odev, $oino) = ($cdev, $cino);
+ chdir('..');
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.');
+ for (;;) {
+ $_ = readdir(DIR);
+ next if $_ eq '.';
+ next if $_ eq '..';
+
+ last unless $_;
+ ($tdev, $tino) = lstat($_);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ unshift(@path, $_);
+ }
+ chdir($path = '/' . join('/', @path));
+ $path;
+}
+1;
diff --git a/Master/tlpkg/tlperl/lib/feature.pm b/Master/tlpkg/tlperl/lib/feature.pm
new file mode 100644
index 00000000000..1517c1ffe81
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/feature.pm
@@ -0,0 +1,236 @@
+package feature;
+
+our $VERSION = '1.16';
+
+# (feature name) => (internal name, used in %^H)
+my %feature = (
+ switch => 'feature_switch',
+ say => "feature_say",
+ state => "feature_state",
+ unicode_strings => "feature_unicode",
+);
+
+# This gets set (for now) in $^H as well as in %^H,
+# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
+# See HINT_UNI_8_BIT in perl.h.
+our $hint_uni8bit = 0x00000800;
+
+# NB. the latest bundle must be loaded by the -E switch (see toke.c)
+
+my %feature_bundle = (
+ "5.10" => [qw(switch say state)],
+ "5.11" => [qw(switch say state unicode_strings)],
+ "5.12" => [qw(switch say state unicode_strings)],
+);
+
+# special case
+$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
+
+# TODO:
+# - think about versioned features (use feature switch => 2)
+
+=head1 NAME
+
+feature - Perl pragma to enable new features
+
+=head1 SYNOPSIS
+
+ use feature qw(switch say);
+ given ($foo) {
+ when (1) { say "\$foo == 1" }
+ when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
+ when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
+ when ($_ > 100) { say "\$foo > 100" }
+ default { say "None of the above" }
+ }
+
+ use feature ':5.10'; # loads all features available in perl 5.10
+
+=head1 DESCRIPTION
+
+It is usually impossible to add new syntax to Perl without breaking
+some existing programs. This pragma provides a way to minimize that
+risk. New syntactic constructs, or new semantic meanings to older
+constructs, can be enabled by C<use feature 'foo'>, and will be parsed
+only when the appropriate feature pragma is in scope.
+
+=head2 Lexical effect
+
+Like other pragmas (C<use strict>, for example), features have a lexical
+effect. C<use feature qw(foo)> will only make the feature "foo" available
+from that point to the end of the enclosing block.
+
+ {
+ use feature 'say';
+ say "say is available here";
+ }
+ print "But not here.\n";
+
+=head2 C<no feature>
+
+Features can also be turned off by using C<no feature "foo">. This too
+has lexical effect.
+
+ use feature 'say';
+ say "say is available here";
+ {
+ no feature 'say';
+ print "But not here.\n";
+ }
+ say "Yet it is here.";
+
+C<no feature> with no features specified will turn off all features.
+
+=head2 The 'switch' feature
+
+C<use feature 'switch'> tells the compiler to enable the Perl 6
+given/when construct.
+
+See L<perlsyn/"Switch statements"> for details.
+
+=head2 The 'say' feature
+
+C<use feature 'say'> tells the compiler to enable the Perl 6
+C<say> function.
+
+See L<perlfunc/say> for details.
+
+=head2 the 'state' feature
+
+C<use feature 'state'> tells the compiler to enable C<state>
+variables.
+
+See L<perlsub/"Persistent Private Variables"> for details.
+
+=head2 the 'unicode_strings' feature
+
+C<use feature 'unicode_strings'> tells the compiler to treat
+all strings outside of C<use locale> and C<use bytes> as Unicode. It is
+available starting with Perl 5.11.3.
+
+See L<perlunicode/The "Unicode Bug"> for details.
+
+=head1 FEATURE BUNDLES
+
+It's possible to load a whole slew of features in one go, using
+a I<feature bundle>. The name of a feature bundle is prefixed with
+a colon, to distinguish it from an actual feature. At present, the
+only feature bundle is C<use feature ":5.10"> which is equivalent
+to C<use feature qw(switch say state)>.
+
+Specifying sub-versions such as the C<0> in C<5.10.0> in feature bundles has
+no effect: feature bundles are guaranteed to be the same for all sub-versions.
+
+=head1 IMPLICIT LOADING
+
+There are two ways to load the C<feature> pragma implicitly :
+
+=over 4
+
+=item *
+
+By using the C<-E> switch on the command-line instead of C<-e>. It enables
+all available features in the main compilation unit (that is, the one-liner.)
+
+=item *
+
+By requiring explicitly a minimal Perl version number for your program, with
+the C<use VERSION> construct, and when the version is higher than or equal to
+5.10.0. That is,
+
+ use 5.10.0;
+
+will do an implicit
+
+ use feature ':5.10';
+
+and so on. Note how the trailing sub-version is automatically stripped from the
+version.
+
+But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
+
+ use 5.010;
+
+with the same effect.
+
+=back
+
+=cut
+
+sub import {
+ my $class = shift;
+ if (@_ == 0) {
+ croak("No features specified");
+ }
+ while (@_) {
+ my $name = shift(@_);
+ if (substr($name, 0, 1) eq ":") {
+ my $v = substr($name, 1);
+ if (!exists $feature_bundle{$v}) {
+ $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
+ if (!exists $feature_bundle{$v}) {
+ unknown_feature_bundle(substr($name, 1));
+ }
+ }
+ unshift @_, @{$feature_bundle{$v}};
+ next;
+ }
+ if (!exists $feature{$name}) {
+ unknown_feature($name);
+ }
+ $^H{$feature{$name}} = 1;
+ $^H |= $hint_uni8bit if $name eq 'unicode_strings';
+ }
+}
+
+sub unimport {
+ my $class = shift;
+
+ # A bare C<no feature> should disable *all* features
+ if (!@_) {
+ delete @^H{ values(%feature) };
+ $^H &= ~ $hint_uni8bit;
+ return;
+ }
+
+ while (@_) {
+ my $name = shift;
+ if (substr($name, 0, 1) eq ":") {
+ my $v = substr($name, 1);
+ if (!exists $feature_bundle{$v}) {
+ $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
+ if (!exists $feature_bundle{$v}) {
+ unknown_feature_bundle(substr($name, 1));
+ }
+ }
+ unshift @_, @{$feature_bundle{$v}};
+ next;
+ }
+ if (!exists($feature{$name})) {
+ unknown_feature($name);
+ }
+ else {
+ delete $^H{$feature{$name}};
+ $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
+ }
+ }
+}
+
+sub unknown_feature {
+ my $feature = shift;
+ croak(sprintf('Feature "%s" is not supported by Perl %vd',
+ $feature, $^V));
+}
+
+sub unknown_feature_bundle {
+ my $feature = shift;
+ croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
+ $feature, $^V));
+}
+
+sub croak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/fields.pm b/Master/tlpkg/tlperl/lib/fields.pm
new file mode 100644
index 00000000000..de6f379d9fe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/fields.pm
@@ -0,0 +1,327 @@
+package fields;
+
+require 5.005;
+use strict;
+no strict 'refs';
+unless( eval q{require warnings::register; warnings::register->import; 1} ) {
+ *warnings::warnif = sub {
+ require Carp;
+ Carp::carp(@_);
+ }
+}
+use vars qw(%attr $VERSION);
+
+$VERSION = '2.15';
+
+# constant.pm is slow
+sub PUBLIC () { 2**0 }
+sub PRIVATE () { 2**1 }
+sub INHERITED () { 2**2 }
+sub PROTECTED () { 2**3 }
+
+
+# The %attr hash holds the attributes of the currently assigned fields
+# per class. The hash is indexed by class names and the hash value is
+# an array reference. The first element in the array is the lowest field
+# number not belonging to a base class. The remaining elements' indices
+# are the field numbers. The values are integer bit masks, or undef
+# in the case of base class private fields (which occupy a slot but are
+# otherwise irrelevant to the class).
+
+sub import {
+ my $class = shift;
+ return unless @_;
+ my $package = caller(0);
+ # avoid possible typo warnings
+ %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
+ my $fields = \%{"$package\::FIELDS"};
+ my $fattr = ($attr{$package} ||= [1]);
+ my $next = @$fattr;
+
+ # Quiet pseudo-hash deprecation warning for uses of fields::new.
+ bless \%{"$package\::FIELDS"}, 'pseudohash';
+
+ if ($next > $fattr->[0]
+ and ($fields->{$_[0]} || 0) >= $fattr->[0])
+ {
+ # There are already fields not belonging to base classes.
+ # Looks like a possible module reload...
+ $next = $fattr->[0];
+ }
+ foreach my $f (@_) {
+ my $fno = $fields->{$f};
+
+ # Allow the module to be reloaded so long as field positions
+ # have not changed.
+ if ($fno and $fno != $next) {
+ require Carp;
+ if ($fno < $fattr->[0]) {
+ if ($] < 5.006001) {
+ warn("Hides field '$f' in base class") if $^W;
+ } else {
+ warnings::warnif("Hides field '$f' in base class") ;
+ }
+ } else {
+ Carp::croak("Field name '$f' already in use");
+ }
+ }
+ $fields->{$f} = $next;
+ $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
+ $next += 1;
+ }
+ if (@$fattr > $next) {
+ # Well, we gave them the benefit of the doubt by guessing the
+ # module was reloaded, but they appear to be declaring fields
+ # in more than one place. We can't be sure (without some extra
+ # bookkeeping) that the rest of the fields will be declared or
+ # have the same positions, so punt.
+ require Carp;
+ Carp::croak ("Reloaded module must declare all fields at once");
+ }
+}
+
+sub inherit {
+ require base;
+ goto &base::inherit_fields;
+}
+
+sub _dump # sometimes useful for debugging
+{
+ for my $pkg (sort keys %attr) {
+ print "\n$pkg";
+ if (@{"$pkg\::ISA"}) {
+ print " (", join(", ", @{"$pkg\::ISA"}), ")";
+ }
+ print "\n";
+ my $fields = \%{"$pkg\::FIELDS"};
+ for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
+ my $no = $fields->{$f};
+ print " $no: $f";
+ my $fattr = $attr{$pkg}[$no];
+ if (defined $fattr) {
+ my @a;
+ push(@a, "public") if $fattr & PUBLIC;
+ push(@a, "private") if $fattr & PRIVATE;
+ push(@a, "inherited") if $fattr & INHERITED;
+ print "\t(", join(", ", @a), ")";
+ }
+ print "\n";
+ }
+ }
+}
+
+if ($] < 5.009) {
+ *new = sub {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ return bless [\%{$class . "::FIELDS"}], $class;
+ }
+} else {
+ *new = sub {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ require Hash::Util;
+ my $self = bless {}, $class;
+
+ # The lock_keys() prototype won't work since we require Hash::Util :(
+ &Hash::Util::lock_keys(\%$self, _accessible_keys($class));
+ return $self;
+ }
+}
+
+sub _accessible_keys {
+ my ($class) = @_;
+ return (
+ keys %{$class.'::FIELDS'},
+ map(_accessible_keys($_), @{$class.'::ISA'}),
+ );
+}
+
+sub phash {
+ die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
+ my $h;
+ my $v;
+ if (@_) {
+ if (ref $_[0] eq 'ARRAY') {
+ my $a = shift;
+ @$h{@$a} = 1 .. @$a;
+ if (@_) {
+ $v = shift;
+ unless (! @_ and ref $v eq 'ARRAY') {
+ require Carp;
+ Carp::croak ("Expected at most two array refs\n");
+ }
+ }
+ }
+ else {
+ if (@_ % 2) {
+ require Carp;
+ Carp::croak ("Odd number of elements initializing pseudo-hash\n");
+ }
+ my $i = 0;
+ @$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
+ $i = 0;
+ $v = [grep $i++ % 2, @_];
+ }
+ }
+ else {
+ $h = {};
+ $v = [];
+ }
+ [ $h, @$v ];
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+fields - compile-time class fields
+
+=head1 SYNOPSIS
+
+ {
+ package Foo;
+ use fields qw(foo bar _Foo_private);
+ sub new {
+ my Foo $self = shift;
+ unless (ref $self) {
+ $self = fields::new($self);
+ $self->{_Foo_private} = "this is Foo's secret";
+ }
+ $self->{foo} = 10;
+ $self->{bar} = 20;
+ return $self;
+ }
+ }
+
+ my $var = Foo->new;
+ $var->{foo} = 42;
+
+ # this will generate an error
+ $var->{zap} = 42;
+
+ # subclassing
+ {
+ package Bar;
+ use base 'Foo';
+ use fields qw(baz _Bar_private); # not shared with Foo
+ sub new {
+ my $class = shift;
+ my $self = fields::new($class);
+ $self->SUPER::new(); # init base fields
+ $self->{baz} = 10; # init own fields
+ $self->{_Bar_private} = "this is Bar's secret";
+ return $self;
+ }
+ }
+
+=head1 DESCRIPTION
+
+The C<fields> pragma enables compile-time verified class fields.
+
+NOTE: The current implementation keeps the declared fields in the %FIELDS
+hash of the calling package, but this may change in future versions.
+Do B<not> update the %FIELDS hash directly, because it must be created
+at compile-time for it to be fully useful, as is done by this pragma.
+
+B<Only valid for perl before 5.9.0:>
+
+If a typed lexical variable holding a reference is used to access a
+hash element and a package with the same name as the type has
+declared class fields using this pragma, then the operation is
+turned into an array access at compile time.
+
+
+The related C<base> pragma will combine fields from base classes and any
+fields declared using the C<fields> pragma. This enables field
+inheritance to work properly.
+
+Field names that start with an underscore character are made private to
+the class and are not visible to subclasses. Inherited fields can be
+overridden but will generate a warning if used together with the C<-w>
+switch.
+
+B<Only valid for perls before 5.9.0:>
+
+The effect of all this is that you can have objects with named
+fields which are as compact and as fast arrays to access. This only
+works as long as the objects are accessed through properly typed
+variables. If the objects are not typed, access is only checked at
+run time.
+
+
+The following functions are supported:
+
+=over 4
+
+=item new
+
+B< perl before 5.9.0: > fields::new() creates and blesses a
+pseudo-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+B< perl 5.9.0 and higher: > fields::new() creates and blesses a
+restricted-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+This function is usable with or without pseudo-hashes. It is the
+recommended way to construct a fields-based object.
+
+This makes it possible to write a constructor like this:
+
+ package Critter::Sounds;
+ use fields qw(cat dog bird);
+
+ sub new {
+ my $self = shift;
+ $self = fields::new($self) unless ref $self;
+ $self->{cat} = 'meow'; # scalar element
+ @$self{'dog','bird'} = ('bark','tweet'); # slice
+ return $self;
+ }
+
+=item phash
+
+B< before perl 5.9.0: >
+
+fields::phash() can be used to create and initialize a plain (unblessed)
+pseudo-hash. This function should always be used instead of creating
+pseudo-hashes directly.
+
+If the first argument is a reference to an array, the pseudo-hash will
+be created with keys from that array. If a second argument is supplied,
+it must also be a reference to an array whose elements will be used as
+the values. If the second array contains less elements than the first,
+the trailing elements of the pseudo-hash will not be initialized.
+This makes it particularly useful for creating a pseudo-hash from
+subroutine arguments:
+
+ sub dogtag {
+ my $tag = fields::phash([qw(name rank ser_num)], [@_]);
+ }
+
+fields::phash() also accepts a list of key-value pairs that will
+be used to construct the pseudo hash. Examples:
+
+ my $tag = fields::phash(name => "Joe",
+ rank => "captain",
+ ser_num => 42);
+
+ my $pseudohash = fields::phash(%args);
+
+B< perl 5.9.0 and higher: >
+
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes or fields::new() instead. Using fields::phash()
+will cause an error.
+
+=back
+
+=head1 SEE ALSO
+
+L<base>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/filetest.pm b/Master/tlpkg/tlperl/lib/filetest.pm
new file mode 100644
index 00000000000..b08f1dc9107
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/filetest.pm
@@ -0,0 +1,117 @@
+package filetest;
+
+our $VERSION = '1.02';
+
+=head1 NAME
+
+filetest - Perl pragma to control the filetest permission operators
+
+=head1 SYNOPSIS
+
+ $can_perhaps_read = -r "file"; # use the mode bits
+ {
+ use filetest 'access'; # intuit harder
+ $can_really_read = -r "file";
+ }
+ $can_perhaps_read = -r "file"; # use the mode bits again
+
+=head1 DESCRIPTION
+
+This pragma tells the compiler to change the behaviour of the filetest
+permission operators, C<-r> C<-w> C<-x> C<-R> C<-W> C<-X>
+(see L<perlfunc>).
+
+The default behaviour of file test operators is to use the simple
+mode bits as returned by the stat() family of system calls. However,
+many operating systems have additional features to define more complex
+access rights, for example ACLs (Access Control Lists).
+For such environments, C<use filetest> may help the permission
+operators to return results more consistent with other tools.
+
+The C<use filetest> or C<no filetest> statements affect file tests defined in
+their block, up to the end of the closest enclosing block (they are lexically
+block-scoped).
+
+Currently, only the C<access> sub-pragma is implemented. It enables (or
+disables) the use of access() when available, that is, on most UNIX systems and
+other POSIX environments. See details below.
+
+=head2 Consider this carefully
+
+The stat() mode bits are probably right for most of the files and
+directories found on your system, because few people want to use the
+additional features offered by access(). But you may encounter surprises
+if your program runs on a system that uses ACLs, since the stat()
+information won't reflect the actual permissions.
+
+There may be a slight performance decrease in the filetest operations
+when the filetest pragma is in effect, because checking bits is very
+cheap.
+
+Also, note that using the file tests for security purposes is a lost cause
+from the start: there is a window open for race conditions (who is to
+say that the permissions will not change between the test and the real
+operation?). Therefore if you are serious about security, just try
+the real operation and test for its success - think in terms of atomic
+operations. Filetests are more useful for filesystem administrative
+tasks, when you have no need for the content of the elements on disk.
+
+=head2 The "access" sub-pragma
+
+UNIX and POSIX systems provide an abstract access() operating system call,
+which should be used to query the read, write, and execute rights. This
+function hides various distinct approaches in additional operating system
+specific security features, like Access Control Lists (ACLs)
+
+The extended filetest functionality is used by Perl only when the argument
+of the operators is a filename, not when it is a filehandle.
+
+=head2 Limitation with regard to C<_>
+
+Because access() does not invoke stat() (at least not in a way visible
+to Perl), B<the stat result cache "_" is not set>. This means that the
+outcome of the following two tests is different. The first has the stat
+bits of C</etc/passwd> in C<_>, and in the second case this still
+contains the bits of C</etc>.
+
+ { -d '/etc';
+ -w '/etc/passwd';
+ print -f _ ? 'Yes' : 'No'; # Yes
+ }
+
+ { use filetest 'access';
+ -d '/etc';
+ -w '/etc/passwd';
+ print -f _ ? 'Yes' : 'No'; # No
+ }
+
+Of course, unless your OS does not implement access(), in which case the
+pragma is simply ignored. Best not to use C<_> at all in a file where
+the filetest pragma is active!
+
+As a side effect, as C<_> doesn't work, stacked filetest operators
+(C<-f -w $file>) won't work either.
+
+This limitation might be removed in a future version of perl.
+
+=cut
+
+$filetest::hint_bits = 0x00400000; # HINT_FILETEST_ACCESS
+
+sub import {
+ if ( $_[1] eq 'access' ) {
+ $^H |= $filetest::hint_bits;
+ } else {
+ die "filetest: the only implemented subpragma is 'access'.\n";
+ }
+}
+
+sub unimport {
+ if ( $_[1] eq 'access' ) {
+ $^H &= ~$filetest::hint_bits;
+ } else {
+ die "filetest: the only implemented subpragma is 'access'.\n";
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/find.pl b/Master/tlpkg/tlperl/lib/find.pl
new file mode 100644
index 00000000000..f79decf8372
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/find.pl
@@ -0,0 +1,52 @@
+# This library is deprecated and unmaintained. It is included for
+# compatibility with Perl 4 scripts which may use it, but it will be
+# removed in a future version of Perl. Please use the File::Find module
+# instead.
+
+# Usage:
+# require "find.pl";
+#
+# &find('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# For example,
+#
+# find / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# corresponds to this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+#
+# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
+
+use File::Find ();
+
+*name = *File::Find::name;
+*prune = *File::Find::prune;
+*dir = *File::Find::dir;
+*topdir = *File::Find::topdir;
+*topdev = *File::Find::topdev;
+*topino = *File::Find::topino;
+*topmode = *File::Find::topmode;
+*topnlink = *File::Find::topnlink;
+
+sub find {
+ &File::Find::find(\&wanted, @_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/finddepth.pl b/Master/tlpkg/tlperl/lib/finddepth.pl
new file mode 100644
index 00000000000..331247ae29d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/finddepth.pl
@@ -0,0 +1,51 @@
+# This library is deprecated and unmaintained. It is included for
+# compatibility with Perl 4 scripts which may use it, but it will be
+# removed in a future version of Perl. Please use the File::Find module
+# instead.
+
+# Usage:
+# require "finddepth.pl";
+#
+# &finddepth('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# For example,
+#
+# find / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# corresponds to this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+
+use File::Find ();
+
+*name = *File::Find::name;
+*prune = *File::Find::prune;
+*dir = *File::Find::dir;
+*topdir = *File::Find::topdir;
+*topdev = *File::Find::topdev;
+*topino = *File::Find::topino;
+*topmode = *File::Find::topmode;
+*topnlink = *File::Find::topnlink;
+
+sub finddepth {
+ &File::Find::finddepth(\&wanted, @_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/flush.pl b/Master/tlpkg/tlperl/lib/flush.pl
new file mode 100644
index 00000000000..e621ff063c7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/flush.pl
@@ -0,0 +1,34 @@
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: IO::Handle
+
+;# Usage: &flush(FILEHANDLE)
+;# flushes the named filehandle
+
+;# Usage: &printflush(FILEHANDLE, "prompt: ")
+;# prints arguments and flushes filehandle
+
+sub flush {
+ local($old) = select(shift);
+ $| = 1;
+ print "";
+ $| = 0;
+ select($old);
+}
+
+sub printflush {
+ local($old) = select(shift);
+ $| = 1;
+ print @_;
+ $| = 0;
+ select($old);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/getcwd.pl b/Master/tlpkg/tlperl/lib/getcwd.pl
new file mode 100644
index 00000000000..fcca2ced80d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/getcwd.pl
@@ -0,0 +1,72 @@
+# By Brandon S. Allbery
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Cwd
+
+#
+# Usage: $cwd = &getcwd;
+
+sub getcwd
+{
+ local($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat('.'))
+ {
+ warn "stat(.): $!";
+ return '';
+ }
+ $cwd = '';
+ do
+ {
+ $dotdots .= '/' if $dotdots;
+ $dotdots .= '..';
+ @pst = @cst;
+ unless (opendir(getcwd'PARENT, $dotdots)) #'))
+ {
+ warn "opendir($dotdots): $!";
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ warn "stat($dotdots): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1])
+ {
+ $dir = '';
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(getcwd'PARENT))) #'))
+ {
+ warn "readdir($dotdots): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ unless (@tst = lstat("$dotdots/$dir"))
+ {
+ # warn "lstat($dotdots/$dir): $!";
+ # closedir(getcwd'PARENT); #');
+ # return '';
+ }
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
+ $tst[$[ + 1] != $pst[$[ + 1]);
+ }
+ $cwd = "$dir/$cwd";
+ closedir(getcwd'PARENT); #');
+ } while ($dir ne '');
+ chop($cwd);
+ $cwd;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/getopt.pl b/Master/tlpkg/tlperl/lib/getopt.pl
new file mode 100644
index 00000000000..343921f39cc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/getopt.pl
@@ -0,0 +1,51 @@
+;# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternatives: Getopt::Long or Getopt::Std
+
+;# 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:
+;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub Getopt {
+ local($argumentative) = @_;
+ local($_,$first,$rest);
+ local($[) = 0;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (index($argumentative,$first) >= $[) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ ${"opt_$first"} = $rest;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/getopts.pl b/Master/tlpkg/tlperl/lib/getopts.pl
new file mode 100644
index 00000000000..b2aa5cb60e1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/getopts.pl
@@ -0,0 +1,66 @@
+;# getopts.pl - a better getopt.pl
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternatives: Getopt::Long or Getopt::Std
+
+;# Usage:
+;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+;# # side effect.
+
+sub Getopts {
+ local($argumentative) = @_;
+ local(@args,$_,$first,$rest);
+ local($errs) = 0;
+ local($[) = 0;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ $pos = index($argumentative,$first);
+ if($pos >= $[) {
+ if($args[$pos+1] eq ':') {
+ shift(@ARGV);
+ if($rest eq '') {
+ ++$errs unless(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ eval "
+ push(\@opt_$first, \$rest);
+ if (!defined \$opt_$first or \$opt_$first eq '') {
+ \$opt_$first = \$rest;
+ }
+ else {
+ \$opt_$first .= ' ' . \$rest;
+ }
+ ";
+ }
+ else {
+ eval "\$opt_$first = 1";
+ if($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ print STDERR "Unknown option: $first\n";
+ ++$errs;
+ if($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ $errs == 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/hostname.pl b/Master/tlpkg/tlperl/lib/hostname.pl
new file mode 100644
index 00000000000..33907c6cb74
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/hostname.pl
@@ -0,0 +1,33 @@
+# From: asherman@fmrco.com (Aaron Sherman)
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Sys::Hostname
+
+sub hostname
+{
+ local(*P,@tmp,$hostname,$_);
+ if (open(P,"hostname 2>&1 |") && (@tmp = <P>) && close(P))
+ {
+ chop($hostname = $tmp[$#tmp]);
+ }
+ elsif (open(P,"uname -n 2>&1 |") && (@tmp = <P>) && close(P))
+ {
+ chop($hostname = $tmp[$#tmp]);
+ }
+ else
+ {
+ die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n";
+ }
+ @tmp = ();
+ close P; # Just in case we failed in an odd spot....
+ $hostname;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/if.pm b/Master/tlpkg/tlperl/lib/if.pm
new file mode 100644
index 00000000000..5f6bcc8ae16
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/if.pm
@@ -0,0 +1,56 @@
+package if;
+
+$VERSION = '0.05';
+
+sub work {
+ my $method = shift() ? 'import' : 'unimport';
+ die "Too few arguments to `use if' (some code returning an empty list in list context?)"
+ unless @_ >= 2;
+ return unless shift; # CONDITION
+
+ my $p = $_[0]; # PACKAGE
+ (my $file = "$p.pm") =~ s!::!/!g;
+ require $file; # Works even if $_[0] is a keyword (like open)
+ my $m = $p->can($method);
+ goto &$m if $m;
+}
+
+sub import { shift; unshift @_, 1; goto &work }
+sub unimport { shift; unshift @_, 0; goto &work }
+
+1;
+__END__
+
+=head1 NAME
+
+if - C<use> a Perl module if a condition holds
+
+=head1 SYNOPSIS
+
+ use if CONDITION, MODULE => ARGUMENTS;
+
+=head1 DESCRIPTION
+
+The construct
+
+ use if CONDITION, MODULE => ARGUMENTS;
+
+has no effect unless C<CONDITION> is true. In this case the effect is
+the same as of
+
+ use MODULE ARGUMENTS;
+
+Above C<< => >> provides necessary quoting of C<MODULE>. If not used (e.g.,
+no ARGUMENTS to give), you'd better quote C<MODULE> yourselves.
+
+=head1 BUGS
+
+The current implementation does not allow specification of the
+required version of the module.
+
+=head1 AUTHOR
+
+Ilya Zakharevich L<mailto:perl-module-if@ilyaz.org>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/importenv.pl b/Master/tlpkg/tlperl/lib/importenv.pl
new file mode 100644
index 00000000000..865a22652d6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/importenv.pl
@@ -0,0 +1,19 @@
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+
+;# This file, when interpreted, pulls the environment into normal variables.
+;# Usage:
+;# require 'importenv.pl';
+;# or
+;# #include <importenv.pl>
+
+local($tmp,$key) = '';
+
+foreach $key (keys(%ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+}
+eval $tmp;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/integer.pm b/Master/tlpkg/tlperl/lib/integer.pm
new file mode 100644
index 00000000000..caa1ea6951f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/integer.pm
@@ -0,0 +1,93 @@
+package integer;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+integer - Perl pragma to use integer arithmetic instead of floating point
+
+=head1 SYNOPSIS
+
+ use integer;
+ $x = 10/3;
+ # $x is now 3, not 3.33333333333333333
+
+=head1 DESCRIPTION
+
+This tells the compiler to use integer operations from here to the end
+of the enclosing BLOCK. On many machines, this doesn't matter a great
+deal for most computations, but on those without floating point
+hardware, it can make a big difference in performance.
+
+Note that this only affects how most of the arithmetic and relational
+B<operators> handle their operands and results, and B<not> how all
+numbers everywhere are treated. Specifically, C<use integer;> has the
+effect that before computing the results of the arithmetic operators
+(+, -, *, /, %, +=, -=, *=, /=, %=, and unary minus), the comparison
+operators (<, <=, >, >=, ==, !=, <=>), and the bitwise operators (|, &,
+^, <<, >>, |=, &=, ^=, <<=, >>=), the operands have their fractional
+portions truncated (or floored), and the result will have its
+fractional portion truncated as well. In addition, the range of
+operands and results is restricted to that of familiar two's complement
+integers, i.e., -(2**31) .. (2**31-1) on 32-bit architectures, and
+-(2**63) .. (2**63-1) on 64-bit architectures. For example, this code
+
+ use integer;
+ $x = 5.8;
+ $y = 2.5;
+ $z = 2.7;
+ $a = 2**31 - 1; # Largest positive integer on 32-bit machines
+ $, = ", ";
+ print $x, -$x, $x + $y, $x - $y, $x / $y, $x * $y, $y == $z, $a, $a + 1;
+
+will print: 5.8, -5, 7, 3, 2, 10, 1, 2147483647, -2147483648
+
+Note that $x is still printed as having its true non-integer value of
+5.8 since it wasn't operated on. And note too the wrap-around from the
+largest positive integer to the largest negative one. Also, arguments
+passed to functions and the values returned by them are B<not> affected
+by C<use integer;>. E.g.,
+
+ srand(1.5);
+ $, = ", ";
+ print sin(.5), cos(.5), atan2(1,2), sqrt(2), rand(10);
+
+will give the same result with or without C<use integer;> The power
+operator C<**> is also not affected, so that 2 ** .5 is always the
+square root of 2. Now, it so happens that the pre- and post- increment
+and decrement operators, ++ and --, are not affected by C<use integer;>
+either. Some may rightly consider this to be a bug -- but at least it's
+a long-standing one.
+
+Finally, C<use integer;> also has an additional affect on the bitwise
+operators. Normally, the operands and results are treated as
+B<unsigned> integers, but with C<use integer;> the operands and results
+are B<signed>. This means, among other things, that ~0 is -1, and -2 &
+-5 is -6.
+
+Internally, native integer arithmetic (as provided by your C compiler)
+is used. This means that Perl's own semantics for arithmetic
+operations may not be preserved. One common source of trouble is the
+modulus of negative numbers, which Perl does one way, but your hardware
+may do another.
+
+ % perl -le 'print (4 % -3)'
+ -2
+ % perl -Minteger -le 'print (4 % -3)'
+ 1
+
+See L<perlmodlib/"Pragmatic Modules">, L<perlop/"Integer Arithmetic">
+
+=cut
+
+$integer::hint_bits = 0x1;
+
+sub import {
+ $^H |= $integer::hint_bits;
+}
+
+sub unimport {
+ $^H &= ~$integer::hint_bits;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/less.pm b/Master/tlpkg/tlperl/lib/less.pm
new file mode 100644
index 00000000000..d2528dfeaf9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/less.pm
@@ -0,0 +1,158 @@
+package less;
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+
+sub _pack_tags {
+ return join ' ', @_;
+}
+
+sub _unpack_tags {
+ return grep { defined and length }
+ map { split ' ' }
+ grep {defined} @_;
+}
+
+sub stash_name { $_[0] }
+
+sub of {
+ my $class = shift @_;
+
+ # If no one wants the result, don't bother computing it.
+ return unless defined wantarray;
+
+ my $hinthash = ( caller 0 )[10];
+ my %tags;
+ @tags{ _unpack_tags( $hinthash->{ $class->stash_name } ) } = ();
+
+ if (@_) {
+ exists $tags{$_} and return !!1 for @_;
+ return;
+ }
+ else {
+ return keys %tags;
+ }
+}
+
+sub import {
+ my $class = shift @_;
+ my $stash = $class->stash_name;
+
+ @_ = 'please' if not @_;
+ my %tags;
+ @tags{ _unpack_tags( @_, $^H{ $stash } ) } = ();
+
+ $^H{$stash} = _pack_tags( keys %tags );
+ return;
+}
+
+sub unimport {
+ my $class = shift @_;
+
+ if (@_) {
+ my %tags;
+ @tags{ _unpack_tags( $^H{$class} ) } = ();
+ delete @tags{ _unpack_tags(@_) };
+ my $new = _pack_tags( keys %tags );
+
+ if ( not length $new ) {
+ delete $^H{ $class->stash_name };
+ }
+ else {
+ $^H{ $class->stash_name } = $new;
+ }
+ }
+ else {
+ delete $^H{ $class->stash_name };
+ }
+
+ return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+less - perl pragma to request less of something
+
+=head1 SYNOPSIS
+
+ use less 'CPU';
+
+=head1 DESCRIPTION
+
+This is a user-pragma. If you're very lucky some code you're using
+will know that you asked for less CPU usage or ram or fat or... we
+just can't know. Consult your documentation on everything you're
+currently using.
+
+For general suggestions, try requesting C<CPU> or C<memory>.
+
+ use less 'memory';
+ use less 'CPU';
+ use less 'fat';
+
+If you ask for nothing in particular, you'll be asking for C<less
+'please'>.
+
+ use less 'please';
+
+=head1 FOR MODULE AUTHORS
+
+L<less> has been in the core as a "joke" module for ages now and it
+hasn't had any real way to communicating any information to
+anything. Thanks to Nicholas Clark we have user pragmas (see
+L<perlpragma>) and now C<less> can do something.
+
+You can probably expect your users to be able to guess that they can
+request less CPU or memory or just "less" overall.
+
+If the user didn't specify anything, it's interpreted as having used
+the C<please> tag. It's up to you to make this useful.
+
+ # equivalent
+ use less;
+ use less 'please';
+
+=head2 C<< BOOLEAN = less->of( FEATURE ) >>
+
+The class method C<< less->of( NAME ) >> returns a boolean to tell you
+whether your user requested less of something.
+
+ if ( less->of( 'CPU' ) ) {
+ ...
+ }
+ elsif ( less->of( 'memory' ) ) {
+
+ }
+
+=head2 C<< FEATURES = less->of() >>
+
+If you don't ask for any feature, you get the list of features that
+the user requested you to be nice to. This has the nice side effect
+that if you don't respect anything in particular then you can just ask
+for it and use it like a boolean.
+
+ if ( less->of ) {
+ ...
+ }
+ else {
+ ...
+ }
+
+=head1 CAVEATS
+
+=over
+
+=item This probably does nothing.
+
+=item This works only on 5.10+
+
+At least it's backwards compatible in not doing much.
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/lib.pm b/Master/tlpkg/tlperl/lib/lib.pm
new file mode 100644
index 00000000000..471d381bb7c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/lib.pm
@@ -0,0 +1,242 @@
+package lib;
+
+# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
+# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
+
+use Config;
+
+use strict;
+
+my $archname = $Config{archname};
+my $version = $Config{version};
+my @inc_version_list = reverse split / /, $Config{inc_version_list};
+
+
+our @ORIG_INC = @INC; # take a handy copy of 'original' value
+our $VERSION = '0.62';
+my $Is_MacOS = $^O eq 'MacOS';
+my $Mac_FS;
+if ($Is_MacOS) {
+ require File::Spec;
+ $Mac_FS = eval { require Mac::FileSpec::Unixish };
+}
+
+sub import {
+ shift;
+
+ my %names;
+ foreach (reverse @_) {
+ my $path = $_; # we'll be modifying it, so break the alias
+ if ($path eq '') {
+ require Carp;
+ Carp::carp("Empty compile time value given to use lib");
+ }
+
+ $path = _nativize($path);
+
+ if ($path !~ /\.par$/i && -e $path && ! -d _) {
+ require Carp;
+ Carp::carp("Parameter to use lib must be directory, not file");
+ }
+ unshift(@INC, $path);
+ # Add any previous version directories we found at configure time
+ foreach my $incver (@inc_version_list)
+ {
+ my $dir = $Is_MacOS
+ ? File::Spec->catdir( $path, $incver )
+ : "$path/$incver";
+ unshift(@INC, $dir) if -d $dir;
+ }
+ # Put a corresponding archlib directory in front of $path if it
+ # looks like $path has an archlib directory below it.
+ my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
+ = _get_dirs($path);
+ unshift(@INC, $arch_dir) if -d $arch_auto_dir;
+ unshift(@INC, $version_dir) if -d $version_dir;
+ unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
+ }
+
+ # remove trailing duplicates
+ @INC = grep { ++$names{$_} == 1 } @INC;
+ return;
+}
+
+
+sub unimport {
+ shift;
+
+ my %names;
+ foreach (@_) {
+ my $path = _nativize($_);
+
+ my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
+ = _get_dirs($path);
+ ++$names{$path};
+ ++$names{$arch_dir} if -d $arch_auto_dir;
+ ++$names{$version_dir} if -d $version_dir;
+ ++$names{$version_arch_dir} if -d $version_arch_dir;
+ }
+
+ # Remove ALL instances of each named directory.
+ @INC = grep { !exists $names{$_} } @INC;
+ return;
+}
+
+sub _get_dirs {
+ my($dir) = @_;
+ my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
+
+ # we could use this for all platforms in the future, but leave it
+ # Mac-only for now, until there is more time for testing it.
+ if ($Is_MacOS) {
+ $arch_auto_dir = File::Spec->catdir( $dir, $archname, 'auto' );
+ $arch_dir = File::Spec->catdir( $dir, $archname, );
+ $version_dir = File::Spec->catdir( $dir, $version );
+ $version_arch_dir = File::Spec->catdir( $dir, $version, $archname );
+ } else {
+ $arch_auto_dir = "$dir/$archname/auto";
+ $arch_dir = "$dir/$archname";
+ $version_dir = "$dir/$version";
+ $version_arch_dir = "$dir/$version/$archname";
+ }
+ return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
+}
+
+sub _nativize {
+ my($dir) = @_;
+
+ if ($Is_MacOS && $Mac_FS && ! -d $dir) {
+ $dir = Mac::FileSpec::Unixish::nativize($dir);
+ $dir .= ":" unless $dir =~ /:$/;
+ }
+
+ return $dir;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+lib - manipulate @INC at compile time
+
+=head1 SYNOPSIS
+
+ use lib LIST;
+
+ no lib LIST;
+
+=head1 DESCRIPTION
+
+This is a small simple module which simplifies the manipulation of @INC
+at compile time.
+
+It is typically used to add extra directories to perl's search path so
+that later C<use> or C<require> statements will find modules which are
+not located on perl's default search path.
+
+=head2 Adding directories to @INC
+
+The parameters to C<use lib> are added to the start of the perl search
+path. Saying
+
+ use lib LIST;
+
+is I<almost> the same as saying
+
+ BEGIN { unshift(@INC, LIST) }
+
+For each directory in LIST (called $dir here) the lib module also
+checks to see if a directory called $dir/$archname/auto exists.
+If so the $dir/$archname directory is assumed to be a corresponding
+architecture specific directory and is added to @INC in front of $dir.
+lib.pm also checks if directories called $dir/$version and $dir/$version/$archname
+exist and adds these directories to @INC.
+
+The current value of C<$archname> can be found with this command:
+
+ perl -V:archname
+
+The corresponding command to get the current value of C<$version> is:
+
+ perl -V:version
+
+To avoid memory leaks, all trailing duplicate entries in @INC are
+removed.
+
+=head2 Deleting directories from @INC
+
+You should normally only add directories to @INC. If you need to
+delete directories from @INC take care to only delete those which you
+added yourself or which you are certain are not needed by other modules
+in your script. Other modules may have added directories which they
+need for correct operation.
+
+The C<no lib> statement deletes all instances of each named directory
+from @INC.
+
+For each directory in LIST (called $dir here) the lib module also
+checks to see if a directory called $dir/$archname/auto exists.
+If so the $dir/$archname directory is assumed to be a corresponding
+architecture specific directory and is also deleted from @INC.
+
+=head2 Restoring original @INC
+
+When the lib module is first loaded it records the current value of @INC
+in an array C<@lib::ORIG_INC>. To restore @INC to that value you
+can say
+
+ @INC = @lib::ORIG_INC;
+
+=head1 CAVEATS
+
+In order to keep lib.pm small and simple, it only works with Unix
+filepaths. This doesn't mean it only works on Unix, but non-Unix
+users must first translate their file paths to Unix conventions.
+
+ # VMS users wanting to put [.stuff.moo] into
+ # their @INC would write
+ use lib 'stuff/moo';
+
+=head1 NOTES
+
+In the future, this module will likely use File::Spec for determining
+paths, as it does now for Mac OS (where Unix-style or Mac-style paths
+work, and Unix-style paths are converted properly to Mac-style paths
+before being added to @INC).
+
+If you try to add a file to @INC as follows:
+
+ use lib 'this_is_a_file.txt';
+
+C<lib> will warn about this. The sole exceptions are files with the
+C<.par> extension which are intended to be used as libraries.
+
+=head1 SEE ALSO
+
+FindBin - optional module which deals with paths relative to the source file.
+
+PAR - optional module which can treat C<.par> files as Perl libraries.
+
+=head1 AUTHOR
+
+Tim Bunce, 2nd June 1995.
+
+C<lib> is maintained by the perl5-porters. Please direct
+any questions to the canonical mailing list. Anything that
+is applicable to the CPAN release can be sent to its maintainer,
+though.
+
+Maintainer: The Perl5-Porters <perl5-porters@perl.org>
+
+Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This package has been part of the perl core since perl 5.001.
+It has been released separately to CPAN so older installations
+can benefit from bug fixes.
+
+This package has the same copyright and license as the perl core.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/locale.pm b/Master/tlpkg/tlperl/lib/locale.pm
new file mode 100644
index 00000000000..a51e2b1c097
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/locale.pm
@@ -0,0 +1,40 @@
+package locale;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+locale - Perl pragma to use and avoid POSIX locales for built-in operations
+
+=head1 SYNOPSIS
+
+ @x = sort @y; # ASCII sorting order
+ {
+ use locale;
+ @x = sort @y; # Locale-defined sorting order
+ }
+ @x = sort @y; # ASCII sorting order again
+
+=head1 DESCRIPTION
+
+This pragma tells the compiler to enable (or disable) the use of POSIX
+locales for built-in operations (LC_CTYPE for regular expressions, and
+LC_COLLATE for string comparison). Each "use locale" or "no locale"
+affects statements to the end of the enclosing BLOCK.
+
+See L<perllocale> for more detailed information on how Perl supports
+locales.
+
+=cut
+
+$locale::hint_bits = 0x4;
+
+sub import {
+ $^H |= $locale::hint_bits;
+}
+
+sub unimport {
+ $^H &= ~$locale::hint_bits;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/look.pl b/Master/tlpkg/tlperl/lib/look.pl
new file mode 100644
index 00000000000..f2a4e09dd6b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/look.pl
@@ -0,0 +1,52 @@
+;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+
+;# Sets file position in FILEHANDLE to be first line greater than or equal
+;# (stringwise) to $key. Pass flags for dictionary order and case folding.
+
+sub look {
+ local(*FH,$key,$dict,$fold) = @_;
+ local($max,$min,$mid,$_);
+ local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(FH);
+ $blksize = 8192 unless $blksize;
+ $key =~ s/[^\w\s]//g if $dict;
+ $key = lc $key if $fold;
+ $max = int($size / $blksize);
+ while ($max - $min > 1) {
+ $mid = int(($max + $min) / 2);
+ seek(FH,$mid * $blksize,0);
+ $_ = <FH> if $mid; # probably a partial line
+ $_ = <FH>;
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ if ($_ lt $key) {
+ $min = $mid;
+ }
+ else {
+ $max = $mid;
+ }
+ }
+ $min *= $blksize;
+ seek(FH,$min,0);
+ <FH> if $min;
+ while (<FH>) {
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ last if $_ ge $key;
+ $min = tell(FH);
+ }
+ seek(FH,$min,0);
+ $min;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/mro.pm b/Master/tlpkg/tlperl/lib/mro.pm
new file mode 100644
index 00000000000..f580bdadf39
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/mro.pm
@@ -0,0 +1,379 @@
+# mro.pm
+#
+# Copyright (c) 2007 Brandon L Black
+# Copyright (c) 2008,2009 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.
+#
+package mro;
+use strict;
+use warnings;
+
+# mro.pm versions < 1.00 reserved for MRO::Compat
+# for partial back-compat to 5.[68].x
+our $VERSION = '1.02';
+
+sub import {
+ mro::set_mro(scalar(caller), $_[1]) if $_[1];
+}
+
+package # hide me from PAUSE
+ next;
+
+sub can { mro::_nextcan($_[0], 0) }
+
+sub method {
+ my $method = mro::_nextcan($_[0], 1);
+ goto &$method;
+}
+
+package # hide me from PAUSE
+ maybe::next;
+
+sub method {
+ my $method = mro::_nextcan($_[0], 0);
+ goto &$method if defined $method;
+ return;
+}
+
+require XSLoader;
+XSLoader::load('mro', $VERSION);
+
+1;
+
+__END__
+
+=head1 NAME
+
+mro - Method Resolution Order
+
+=head1 SYNOPSIS
+
+ use mro; # enables next::method and friends globally
+
+ use mro 'dfs'; # enable DFS MRO for this class (Perl default)
+ use mro 'c3'; # enable C3 MRO for this class
+
+=head1 DESCRIPTION
+
+The "mro" namespace provides several utilities for dealing
+with method resolution order and method caching in general.
+
+These interfaces are only available in Perl 5.9.5 and higher.
+See L<MRO::Compat> on CPAN for a mostly forwards compatible
+implementation for older Perls.
+
+=head1 OVERVIEW
+
+It's possible to change the MRO of a given class either by using C<use
+mro> as shown in the synopsis, or by using the L</mro::set_mro> function
+below.
+
+The special methods C<next::method>, C<next::can>, and
+C<maybe::next::method> are not available until this C<mro> module
+has been loaded via C<use> or C<require>.
+
+=head1 The C3 MRO
+
+In addition to the traditional Perl default MRO (depth first
+search, called C<DFS> here), Perl now offers the C3 MRO as
+well. Perl's support for C3 is based on the work done in
+Stevan Little's module L<Class::C3>, and most of the C3-related
+documentation here is ripped directly from there.
+
+=head2 What is C3?
+
+C3 is the name of an algorithm which aims to provide a sane method
+resolution order under multiple inheritance. It was first introduced in
+the language Dylan (see links in the L</"SEE ALSO"> section), and then
+later adopted as the preferred MRO (Method Resolution Order) for the
+new-style classes in Python 2.3. Most recently it has been adopted as the
+"canonical" MRO for Perl 6 classes, and the default MRO for Parrot objects
+as well.
+
+=head2 How does C3 work
+
+C3 works by always preserving local precedence ordering. This essentially
+means that no class will appear before any of its subclasses. Take, for
+instance, the classic diamond inheritance pattern:
+
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
+
+The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A>
+appears before B<C>, even though B<C> is the subclass of B<A>. The C3 MRO
+algorithm however, produces the following order: (D, B, C, A), which does
+not have this issue.
+
+This example is fairly trivial; for more complex cases and a deeper
+explanation, see the links in the L</"SEE ALSO"> section.
+
+=head1 Functions
+
+=head2 mro::get_linear_isa($classname[, $type])
+
+Returns an arrayref which is the linearized MRO of the given class.
+Uses whichever MRO is currently in effect for that class by default,
+or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
+
+The linearized MRO of a class is an ordered array of all of the
+classes one would search when resolving a method on that class,
+starting with the class itself.
+
+If the requested class doesn't yet exist, this function will still
+succeed, and return C<[ $classname ]>
+
+Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
+part of the MRO of a class, even though all classes implicitly inherit
+methods from C<UNIVERSAL> and its parents.
+
+=head2 mro::set_mro ($classname, $type)
+
+Sets the MRO of the given class to the C<$type> argument (either
+C<c3> or C<dfs>).
+
+=head2 mro::get_mro($classname)
+
+Returns the MRO of the given class (either C<c3> or C<dfs>).
+
+=head2 mro::get_isarev($classname)
+
+Gets the C<mro_isarev> for this class, returned as an
+arrayref of class names. These are every class that "isa"
+the given class name, even if the isa relationship is
+indirect. This is used internally by the MRO code to
+keep track of method/MRO cache invalidations.
+
+Currently, this list only grows, it never shrinks. This
+was a performance consideration (properly tracking and
+deleting isarev entries when someone removes an entry
+from an C<@ISA> is costly, and it doesn't happen often
+anyways). The fact that a class which no longer truly
+"isa" this class at runtime remains on the list should be
+considered a quirky implementation detail which is subject
+to future change. It shouldn't be an issue as long as
+you're looking at this list for the same reasons the
+core code does: as a performance optimization
+over having to search every class in existence.
+
+As with C<mro::get_mro> above, C<UNIVERSAL> is special.
+C<UNIVERSAL> (and parents') isarev lists do not include
+every class in existence, even though all classes are
+effectively descendants for method inheritance purposes.
+
+=head2 mro::is_universal($classname)
+
+Returns a boolean status indicating whether or not
+the given classname is either C<UNIVERSAL> itself,
+or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
+
+Any class for which this function returns true is
+"universal" in the sense that all classes potentially
+inherit methods from it.
+
+For similar reasons to C<isarev> above, this flag is
+permanent. Once it is set, it does not go away, even
+if the class in question really isn't universal anymore.
+
+=head2 mro::invalidate_all_method_caches()
+
+Increments C<PL_sub_generation>, which invalidates method
+caching in all packages.
+
+=head2 mro::method_changed_in($classname)
+
+Invalidates the method cache of any classes dependent on the
+given class. This is not normally necessary. The only
+known case where pure perl code can confuse the method
+cache is when you manually install a new constant
+subroutine by using a readonly scalar value, like the
+internals of L<constant> do. If you find another case,
+please report it so we can either fix it or document
+the exception here.
+
+=head2 mro::get_pkg_gen($classname)
+
+Returns an integer which is incremented every time a
+real local method in the package C<$classname> changes,
+or the local C<@ISA> of C<$classname> is modified.
+
+This is intended for authors of modules which do lots
+of class introspection, as it allows them to very quickly
+check if anything important about the local properties
+of a given class have changed since the last time they
+looked. It does not increment on method/C<@ISA>
+changes in superclasses.
+
+It's still up to you to seek out the actual changes,
+and there might not actually be any. Perhaps all
+of the changes since you last checked cancelled each
+other out and left the package in the state it was in
+before.
+
+This integer normally starts off at a value of C<1>
+when a package stash is instantiated. Calling it
+on packages whose stashes do not exist at all will
+return C<0>. If a package stash is completely
+deleted (not a normal occurence, but it can happen
+if someone does something like C<undef %PkgName::>),
+the number will be reset to either C<0> or C<1>,
+depending on how completely package was wiped out.
+
+=head2 next::method
+
+This is somewhat like C<SUPER>, but it uses the C3 method
+resolution order to get better consistency in multiple
+inheritance situations. Note that while inheritance in
+general follows whichever MRO is in effect for the
+given class, C<next::method> only uses the C3 MRO.
+
+One generally uses it like so:
+
+ sub some_method {
+ my $self = shift;
+ my $superclass_answer = $self->next::method(@_);
+ return $superclass_answer + 1;
+ }
+
+Note that you don't (re-)specify the method name.
+It forces you to always use the same method name
+as the method you started in.
+
+It can be called on an object or a class, of course.
+
+The way it resolves which actual method to call is:
+
+=over 4
+
+=item 1
+
+First, it determines the linearized C3 MRO of
+the object or class it is being called on.
+
+=item 2
+
+Then, it determines the class and method name
+of the context it was invoked from.
+
+=item 3
+
+Finally, it searches down the C3 MRO list until
+it reaches the contextually enclosing class, then
+searches further down the MRO list for the next
+method with the same name as the contextually
+enclosing method.
+
+=back
+
+Failure to find a next method will result in an
+exception being thrown (see below for alternatives).
+
+This is substantially different than the behavior
+of C<SUPER> under complex multiple inheritance.
+(This becomes obvious when one realizes that the
+common superclasses in the C3 linearizations of
+a given class and one of its parents will not
+always be ordered the same for both.)
+
+B<Caveat>: Calling C<next::method> from methods defined outside the class:
+
+There is an edge case when using C<next::method> from within a subroutine
+which was created in a different module than the one it is called from. It
+sounds complicated, but it really isn't. Here is an example which will not
+work correctly:
+
+ *Foo::foo = sub { (shift)->next::method(@_) };
+
+The problem exists because the anonymous subroutine being assigned to the
+C<*Foo::foo> glob will show up in the call stack as being called
+C<__ANON__> and not C<foo> as you might expect. Since C<next::method> uses
+C<caller> to find the name of the method it was called in, it will fail in
+this case.
+
+But fear not, there's a simple solution. The module C<Sub::Name> will
+reach into the perl internals and assign a name to an anonymous subroutine
+for you. Simply do this:
+
+ use Sub::Name 'subname';
+ *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
+
+and things will Just Work.
+
+=head2 next::can
+
+This is similar to C<next::method>, but just returns either a code
+reference or C<undef> to indicate that no further methods of this name
+exist.
+
+=head2 maybe::next::method
+
+In simple cases, it is equivalent to:
+
+ $self->next::method(@_) if $self->next::can;
+
+But there are some cases where only this solution
+works (like C<goto &maybe::next::method>);
+
+=head1 SEE ALSO
+
+=head2 The original Dylan paper
+
+=over 4
+
+=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
+
+=back
+
+=head2 Pugs
+
+The Pugs prototype Perl 6 Object Model uses C3
+
+=head2 Parrot
+
+Parrot now uses C3
+
+=over 4
+
+=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
+
+=item L<http://use.perl.org/~autrijus/journal/25768>
+
+=back
+
+=head2 Python 2.3 MRO related links
+
+=over 4
+
+=item L<http://www.python.org/2.3/mro.html>
+
+=item L<http://www.python.org/2.2.2/descrintro.html#mro>
+
+=back
+
+=head2 C3 for TinyCLOS
+
+=over 4
+
+=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
+
+=back
+
+=head2 Class::C3
+
+=over 4
+
+=item L<Class::C3>
+
+=back
+
+=head1 AUTHOR
+
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
+Based on Stevan Little's L<Class::C3>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/newgetopt.pl b/Master/tlpkg/tlperl/lib/newgetopt.pl
new file mode 100644
index 00000000000..d6d8b0b07bf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/newgetopt.pl
@@ -0,0 +1,77 @@
+# $Id: newgetopt.pl,v 1.18 2001/09/21 13:34:59 jv Exp $
+
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# It is now just a wrapper around the Getopt::Long module.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Getopt::Long
+
+{ package newgetopt;
+
+ # Values for $order. See GNU getopt.c for details.
+ $REQUIRE_ORDER = 0;
+ $PERMUTE = 1;
+ $RETURN_IN_ORDER = 2;
+
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $autoabbrev = 0; # no automatic abbrev of options (???)
+ $getopt_compat = 0; # disallow '+' to start options
+ $option_start = "(--|-)";
+ $order = $REQUIRE_ORDER;
+ $bundling = 0;
+ $passthrough = 0;
+ }
+ else {
+ $autoabbrev = 1; # automatic abbrev of options
+ $getopt_compat = 1; # allow '+' to start options
+ $option_start = "(--|-|\\+)";
+ $order = $PERMUTE;
+ $bundling = 0;
+ $passthrough = 0;
+ }
+
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $ignorecase = 1; # ignore case when matching options
+ $argv_end = "--"; # don't change this!
+}
+
+use Getopt::Long;
+
+################ Subroutines ################
+
+sub NGetOpt {
+
+ $Getopt::Long::debug = $newgetopt::debug
+ if defined $newgetopt::debug;
+ $Getopt::Long::autoabbrev = $newgetopt::autoabbrev
+ if defined $newgetopt::autoabbrev;
+ $Getopt::Long::getopt_compat = $newgetopt::getopt_compat
+ if defined $newgetopt::getopt_compat;
+ $Getopt::Long::option_start = $newgetopt::option_start
+ if defined $newgetopt::option_start;
+ $Getopt::Long::order = $newgetopt::order
+ if defined $newgetopt::order;
+ $Getopt::Long::bundling = $newgetopt::bundling
+ if defined $newgetopt::bundling;
+ $Getopt::Long::ignorecase = $newgetopt::ignorecase
+ if defined $newgetopt::ignorecase;
+ $Getopt::Long::ignorecase = $newgetopt::ignorecase
+ if defined $newgetopt::ignorecase;
+ $Getopt::Long::passthrough = $newgetopt::passthrough
+ if defined $newgetopt::passthrough;
+
+ &GetOptions;
+}
+
+################ Package return ################
+
+1;
+
+################ End of newgetopt.pl ################
diff --git a/Master/tlpkg/tlperl/lib/open.pm b/Master/tlpkg/tlperl/lib/open.pm
new file mode 100644
index 00000000000..a6b4250e325
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/open.pm
@@ -0,0 +1,258 @@
+package open;
+use warnings;
+
+our $VERSION = '1.07';
+
+require 5.008001; # for PerlIO::get_layers()
+
+my $locale_encoding;
+
+sub _get_encname {
+ return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
+ return;
+}
+
+sub croak {
+ require Carp; goto &Carp::croak;
+}
+
+sub _drop_oldenc {
+ # If by the time we arrive here there already is at the top of the
+ # perlio layer stack an encoding identical to what we would like
+ # to push via this open pragma, we will pop away the old encoding
+ # (+utf8) so that we can push ourselves in place (this is easier
+ # than ignoring pushing ourselves because of the way how ${^OPEN}
+ # works). So we are looking for something like
+ #
+ # stdio encoding(xxx) utf8
+ #
+ # in the existing layer stack, and in the new stack chunk for
+ #
+ # :encoding(xxx)
+ #
+ # If we find a match, we pop the old stack (once, since
+ # the utf8 is just a flag on the encoding layer)
+ my ($h, @new) = @_;
+ return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
+ my @old = PerlIO::get_layers($h);
+ return unless @old >= 3 &&
+ $old[-1] eq 'utf8' &&
+ $old[-2] =~ /^encoding\(.+\)$/;
+ require Encode;
+ my ($loname, $lcname) = _get_encname($old[-2]);
+ unless (defined $lcname) { # Should we trust get_layers()?
+ croak("open: Unknown encoding '$loname'");
+ }
+ my ($voname, $vcname) = _get_encname($new[-1]);
+ unless (defined $vcname) {
+ croak("open: Unknown encoding '$voname'");
+ }
+ if ($lcname eq $vcname) {
+ binmode($h, ":pop"); # utf8 is part of the encoding layer
+ }
+}
+
+sub import {
+ my ($class,@args) = @_;
+ croak("open: needs explicit list of PerlIO layers") unless @args;
+ my $std;
+ my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
+ while (@args) {
+ my $type = shift(@args);
+ my $dscp;
+ if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
+ $type = 'IO';
+ $dscp = ":$1";
+ } elsif ($type eq ':std') {
+ $std = 1;
+ next;
+ } else {
+ $dscp = shift(@args) || '';
+ }
+ my @val;
+ foreach my $layer (split(/\s+/,$dscp)) {
+ $layer =~ s/^://;
+ if ($layer eq 'locale') {
+ require Encode;
+ require encoding;
+ $locale_encoding = encoding::_get_locale_encoding()
+ unless defined $locale_encoding;
+ (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
+ unless defined $locale_encoding;
+ $layer = "encoding($locale_encoding)";
+ $std = 1;
+ } else {
+ my $target = $layer; # the layer name itself
+ $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
+
+ unless(PerlIO::Layer::->find($target,1)) {
+ warnings::warnif("layer", "Unknown PerlIO layer '$target'");
+ }
+ }
+ push(@val,":$layer");
+ if ($layer =~ /^(crlf|raw)$/) {
+ $^H{"open_$type"} = $layer;
+ }
+ }
+ if ($type eq 'IN') {
+ _drop_oldenc(*STDIN, @val);
+ $in = join(' ', @val);
+ }
+ elsif ($type eq 'OUT') {
+ _drop_oldenc(*STDOUT, @val);
+ $out = join(' ', @val);
+ }
+ elsif ($type eq 'IO') {
+ _drop_oldenc(*STDIN, @val);
+ _drop_oldenc(*STDOUT, @val);
+ $in = $out = join(' ', @val);
+ }
+ else {
+ croak "Unknown PerlIO layer class '$type'";
+ }
+ }
+ ${^OPEN} = join("\0", $in, $out);
+ if ($std) {
+ if ($in) {
+ if ($in =~ /:utf8\b/) {
+ binmode(STDIN, ":utf8");
+ } elsif ($in =~ /(\w+\(.+\))/) {
+ binmode(STDIN, ":$1");
+ }
+ }
+ if ($out) {
+ if ($out =~ /:utf8\b/) {
+ binmode(STDOUT, ":utf8");
+ binmode(STDERR, ":utf8");
+ } elsif ($out =~ /(\w+\(.+\))/) {
+ binmode(STDOUT, ":$1");
+ binmode(STDERR, ":$1");
+ }
+ }
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+open - perl pragma to set default PerlIO layers for input and output
+
+=head1 SYNOPSIS
+
+ use open IN => ":crlf", OUT => ":bytes";
+ use open OUT => ':utf8';
+ use open IO => ":encoding(iso-8859-7)";
+
+ use open IO => ':locale';
+
+ use open ':encoding(utf8)';
+ use open ':locale';
+ use open ':encoding(iso-8859-7)';
+
+ use open ':std';
+
+=head1 DESCRIPTION
+
+Full-fledged support for I/O layers is now implemented provided
+Perl is configured to use PerlIO as its IO system (which is now the
+default).
+
+The C<open> pragma serves as one of the interfaces to declare default
+"layers" (also known as "disciplines") for all I/O. Any two-argument
+open(), readpipe() (aka qx//) and similar operators found within the
+lexical scope of this pragma will use the declared defaults.
+Even three-argument opens may be affected by this pragma
+when they don't specify IO layers in MODE.
+
+With the C<IN> subpragma you can declare the default layers
+of input streams, and with the C<OUT> subpragma you can declare
+the default layers of output streams. With the C<IO> subpragma
+you can control both input and output streams simultaneously.
+
+If you have a legacy encoding, you can use the C<:encoding(...)> tag.
+
+If you want to set your encoding layers based on your
+locale environment variables, you can use the C<:locale> tag.
+For example:
+
+ $ENV{LANG} = 'ru_RU.KOI8-R';
+ # the :locale will probe the locale environment variables like LANG
+ use open OUT => ':locale';
+ open(O, ">koi8");
+ print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
+ close O;
+ open(I, "<koi8");
+ printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
+ close I;
+
+These are equivalent
+
+ use open ':encoding(utf8)';
+ use open IO => ':encoding(utf8)';
+
+as are these
+
+ use open ':locale';
+ use open IO => ':locale';
+
+and these
+
+ use open ':encoding(iso-8859-7)';
+ use open IO => ':encoding(iso-8859-7)';
+
+The matching of encoding names is loose: case does not matter, and
+many encodings have several aliases. See L<Encode::Supported> for
+details and the list of supported locales.
+
+When open() is given an explicit list of layers (with the three-arg
+syntax), they override the list declared using this pragma.
+
+The C<:std> subpragma on its own has no effect, but if combined with
+the C<:utf8> or C<:encoding> subpragmas, it converts the standard
+filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
+for input/output handles. For example, if both input and out are
+chosen to be C<:encoding(utf8)>, a C<:std> will mean that STDIN, STDOUT,
+and STDERR are also in C<:encoding(utf8)>. On the other hand, if only
+output is chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause
+only the STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma
+implicitly turns on C<:std>.
+
+The logic of C<:locale> is described in full in L<encoding>,
+but in short it is first trying nl_langinfo(CODESET) and then
+guessing from the LC_ALL and LANG locale environment variables.
+
+Directory handles may also support PerlIO layers in the future.
+
+=head1 NONPERLIO FUNCTIONALITY
+
+If Perl is not built to use PerlIO as its IO system then only the two
+pseudo-layers C<:bytes> and C<:crlf> are available.
+
+The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
+layer corresponds to "text mode" on platforms that distinguish
+between the two modes when opening files (which is many DOS-like
+platforms, including Windows). These two layers are no-ops on
+platforms where binmode() is a no-op, but perform their functions
+everywhere if PerlIO is enabled.
+
+=head1 IMPLEMENTATION DETAILS
+
+There is a class method in C<PerlIO::Layer> C<find> which is
+implemented as XS code. It is called by C<import> to validate the
+layers:
+
+ PerlIO::Layer::->find("perlio")
+
+The return value (if defined) is a Perl object, of class
+C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As
+yet there is nothing useful you can do with the object at the perl
+level.
+
+=head1 SEE ALSO
+
+L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
+L<encoding>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/open2.pl b/Master/tlpkg/tlperl/lib/open2.pl
new file mode 100644
index 00000000000..96d80d7b26a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/open2.pl
@@ -0,0 +1,15 @@
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# This is a compatibility interface to IPC::Open2. New programs should
+# do
+#
+# use IPC::Open2;
+#
+# instead of
+#
+# require 'open2.pl';
+
+package main;
+use IPC::Open2 'open2';
+1
diff --git a/Master/tlpkg/tlperl/lib/open3.pl b/Master/tlpkg/tlperl/lib/open3.pl
new file mode 100644
index 00000000000..9a387eb9a01
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/open3.pl
@@ -0,0 +1,15 @@
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# This is a compatibility interface to IPC::Open3. New programs should
+# do
+#
+# use IPC::Open3;
+#
+# instead of
+#
+# require 'open3.pl';
+
+package main;
+use IPC::Open3 'open3';
+1
diff --git a/Master/tlpkg/tlperl/lib/ops.pm b/Master/tlpkg/tlperl/lib/ops.pm
new file mode 100644
index 00000000000..4183669eb16
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/ops.pm
@@ -0,0 +1,47 @@
+package ops;
+
+our $VERSION = '1.02';
+
+use Opcode qw(opmask_add opset invert_opset);
+
+sub import {
+ shift;
+ # Not that unimport is the preferred form since import's don't
+ # accumulate well owing to the 'only ever add opmask' rule.
+ # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected.
+ opmask_add(invert_opset opset(@_)) if @_;
+}
+
+sub unimport {
+ shift;
+ opmask_add(opset(@_)) if @_;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ops - Perl pragma to restrict unsafe operations when compiling
+
+=head1 SYNOPSIS
+
+ perl -Mops=:default ... # only allow reasonably safe operations
+
+ perl -M-ops=system ... # disable the 'system' opcode
+
+=head1 DESCRIPTION
+
+Since the C<ops> pragma currently has an irreversible global effect, it is
+only of significant practical use with the C<-M> option on the command line.
+
+See the L<Opcode> module for information about opcodes, optags, opmasks
+and important information about safety.
+
+=head1 SEE ALSO
+
+L<Opcode>, L<Safe>, L<perlrun>
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/overload.pm b/Master/tlpkg/tlperl/lib/overload.pm
new file mode 100644
index 00000000000..7d09d69e055
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/overload.pm
@@ -0,0 +1,1534 @@
+package overload;
+
+our $VERSION = '1.10';
+
+sub nil {}
+
+sub OVERLOAD {
+ $package = shift;
+ my %arg = @_;
+ my ($sub, $fb);
+ $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
+ $fb = ${$package . "::()"}; # preserve old fallback value RT#68196
+ *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
+ for (keys %arg) {
+ if ($_ eq 'fallback') {
+ $fb = $arg{$_};
+ } else {
+ $sub = $arg{$_};
+ if (not ref $sub and $sub !~ /::/) {
+ $ {$package . "::(" . $_} = $sub;
+ $sub = \&nil;
+ }
+ #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
+ *{$package . "::(" . $_} = \&{ $sub };
+ }
+ }
+ ${$package . "::()"} = $fb; # Make it findable too (fallback only).
+}
+
+sub import {
+ $package = (caller())[0];
+ # *{$package . "::OVERLOAD"} = \&OVERLOAD;
+ shift;
+ $package->overload::OVERLOAD(@_);
+}
+
+sub unimport {
+ $package = (caller())[0];
+ ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
+ shift;
+ for (@_) {
+ if ($_ eq 'fallback') {
+ undef $ {$package . "::()"};
+ } else {
+ delete $ {$package . "::"}{"(" . $_};
+ }
+ }
+}
+
+sub Overloaded {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ $package->can('()');
+}
+
+sub ov_method {
+ my $globref = shift;
+ return undef unless $globref;
+ my $sub = \&{*$globref};
+ return $sub if $sub ne \&nil;
+ return shift->can($ {*$globref});
+}
+
+sub OverloadedStringify {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ #$package->can('(""')
+ ov_method mycan($package, '(""'), $package
+ or ov_method mycan($package, '(0+'), $package
+ or ov_method mycan($package, '(bool'), $package
+ or ov_method mycan($package, '(nomethod'), $package;
+}
+
+sub Method {
+ my $package = shift;
+ if(ref $package) {
+ local $@;
+ local $!;
+ require Scalar::Util;
+ $package = Scalar::Util::blessed($package);
+ return undef if !defined $package;
+ }
+ #my $meth = $package->can('(' . shift);
+ ov_method mycan($package, '(' . shift), $package;
+ #return $meth if $meth ne \&nil;
+ #return $ {*{$meth}};
+}
+
+sub AddrRef {
+ my $package = ref $_[0];
+ return "$_[0]" unless $package;
+
+ local $@;
+ local $!;
+ require Scalar::Util;
+ my $class = Scalar::Util::blessed($_[0]);
+ my $class_prefix = defined($class) ? "$class=" : "";
+ my $type = Scalar::Util::reftype($_[0]);
+ my $addr = Scalar::Util::refaddr($_[0]);
+ return sprintf("$class_prefix$type(0x%x)", $addr);
+}
+
+*StrVal = *AddrRef;
+
+sub mycan { # Real can would leave stubs.
+ my ($package, $meth) = @_;
+
+ local $@;
+ local $!;
+ require mro;
+
+ my $mro = mro::get_linear_isa($package);
+ foreach my $p (@$mro) {
+ my $fqmeth = $p . q{::} . $meth;
+ return \*{$fqmeth} if defined &{$fqmeth};
+ }
+
+ return undef;
+}
+
+%constants = (
+ 'integer' => 0x1000, # HINT_NEW_INTEGER
+ 'float' => 0x2000, # HINT_NEW_FLOAT
+ 'binary' => 0x4000, # HINT_NEW_BINARY
+ 'q' => 0x8000, # HINT_NEW_STRING
+ 'qr' => 0x10000, # HINT_NEW_RE
+ );
+
+%ops = ( with_assign => "+ - * / % ** << >> x .",
+ assign => "+= -= *= /= %= **= <<= >>= x= .=",
+ num_comparison => "< <= > >= == !=",
+ '3way_comparison'=> "<=> cmp",
+ str_comparison => "lt le gt ge eq ne",
+ binary => '& &= | |= ^ ^=',
+ unary => "neg ! ~",
+ mutators => '++ --',
+ func => "atan2 cos sin exp abs log sqrt int",
+ conversion => 'bool "" 0+ qr',
+ iterators => '<>',
+ filetest => "-X",
+ dereferencing => '${} @{} %{} &{} *{}',
+ matching => '~~',
+ special => 'nomethod fallback =');
+
+use warnings::register;
+sub constant {
+ # Arguments: what, sub
+ while (@_) {
+ if (@_ == 1) {
+ warnings::warnif ("Odd number of arguments for overload::constant");
+ last;
+ }
+ elsif (!exists $constants {$_ [0]}) {
+ warnings::warnif ("`$_[0]' is not an overloadable type");
+ }
+ elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
+ # Can't use C<ref $_[1] eq "CODE"> above as code references can be
+ # blessed, and C<ref> would return the package the ref is blessed into.
+ if (warnings::enabled) {
+ $_ [1] = "undef" unless defined $_ [1];
+ warnings::warn ("`$_[1]' is not a code reference");
+ }
+ }
+ else {
+ $^H{$_[0]} = $_[1];
+ $^H |= $constants{$_[0]};
+ }
+ shift, shift;
+ }
+}
+
+sub remove_constant {
+ # Arguments: what, sub
+ while (@_) {
+ delete $^H{$_[0]};
+ $^H &= ~ $constants{$_[0]};
+ shift, shift;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+overload - Package for overloading Perl operations
+
+=head1 SYNOPSIS
+
+ package SomeThing;
+
+ use overload
+ '+' => \&myadd,
+ '-' => \&mysub;
+ # etc
+ ...
+
+ package main;
+ $a = SomeThing->new( 57 );
+ $b=5+$a;
+ ...
+ if (overload::Overloaded $b) {...}
+ ...
+ $strval = overload::StrVal $b;
+
+=head1 DESCRIPTION
+
+This pragma allows overloading of Perl's operators for a class.
+To overload built-in functions, see L<perlsub/Overriding Built-in Functions> instead.
+
+=head2 Declaration of overloaded functions
+
+The compilation directive
+
+ package Number;
+ use overload
+ "+" => \&add,
+ "*=" => "muas";
+
+declares function Number::add() for addition, and method muas() in
+the "class" C<Number> (or one of its base classes)
+for the assignment form C<*=> of multiplication.
+
+Arguments of this directive come in (key, value) pairs. Legal values
+are values legal inside a C<&{ ... }> call, so the name of a
+subroutine, a reference to a subroutine, or an anonymous subroutine
+will all work. Note that values specified as strings are
+interpreted as methods, not subroutines. Legal keys are listed below.
+
+The subroutine C<add> will be called to execute C<$a+$b> if $a
+is a reference to an object blessed into the package C<Number>, or if $a is
+not an object from a package with defined mathemagic addition, but $b is a
+reference to a C<Number>. It can also be called in other situations, like
+C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical
+methods refer to methods triggered by an overloaded mathematical
+operator.)
+
+Since overloading respects inheritance via the @ISA hierarchy, the
+above declaration would also trigger overloading of C<+> and C<*=> in
+all the packages which inherit from C<Number>.
+
+=head2 Calling Conventions for Binary Operations
+
+The functions specified in the C<use overload ...> directive are called
+with three (in one particular case with four, see L<Last Resort>)
+arguments. If the corresponding operation is binary, then the first
+two arguments are the two arguments of the operation. However, due to
+general object calling conventions, the first argument should always be
+an object in the package, so in the situation of C<7+$a>, the
+order of the arguments is interchanged. It probably does not matter
+when implementing the addition method, but whether the arguments
+are reversed is vital to the subtraction method. The method can
+query this information by examining the third argument, which can take
+three different values:
+
+=over 7
+
+=item FALSE
+
+the order of arguments is as in the current operation.
+
+=item TRUE
+
+the arguments are reversed.
+
+=item C<undef>
+
+the current operation is an assignment variant (as in
+C<$a+=7>), but the usual function is called instead. This additional
+information can be used to generate some optimizations. Compare
+L<Calling Conventions for Mutators>.
+
+=back
+
+=head2 Calling Conventions for Unary Operations
+
+Unary operation are considered binary operations with the second
+argument being C<undef>. Thus the functions that overloads C<{"++"}>
+is called with arguments C<($a,undef,'')> when $a++ is executed.
+
+=head2 Calling Conventions for Mutators
+
+Two types of mutators have different calling conventions:
+
+=over
+
+=item C<++> and C<-->
+
+The routines which implement these operators are expected to actually
+I<mutate> their arguments. So, assuming that $obj is a reference to a
+number,
+
+ sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n}
+
+is an appropriate implementation of overloaded C<++>. Note that
+
+ sub incr { ++$ {$_[0]} ; shift }
+
+is OK if used with preincrement and with postincrement. (In the case
+of postincrement a copying will be performed, see L<Copy Constructor>.)
+
+=item C<x=> and other assignment versions
+
+There is nothing special about these methods. They may change the
+value of their arguments, and may leave it as is. The result is going
+to be assigned to the value in the left-hand-side if different from
+this value.
+
+This allows for the same method to be used as overloaded C<+=> and
+C<+>. Note that this is I<allowed>, but not recommended, since by the
+semantic of L<"Fallback"> Perl will call the method for C<+> anyway,
+if C<+=> is not overloaded.
+
+=back
+
+B<Warning.> Due to the presence of assignment versions of operations,
+routines which may be called in assignment context may create
+self-referential structures. Currently Perl will not free self-referential
+structures until cycles are C<explicitly> broken. You may get problems
+when traversing your structures too.
+
+Say,
+
+ use overload '+' => sub { bless [ \$_[0], \$_[1] ] };
+
+is asking for trouble, since for code C<$obj += $foo> the subroutine
+is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj,
+\$foo]>. If using such a subroutine is an important optimization, one
+can overload C<+=> explicitly by a non-"optimized" version, or switch
+to non-optimized version if C<not defined $_[2]> (see
+L<Calling Conventions for Binary Operations>).
+
+Even if no I<explicit> assignment-variants of operators are present in
+the script, they may be generated by the optimizer. Say, C<",$obj,"> or
+C<',' . $obj . ','> may be both optimized to
+
+ my $tmp = ',' . $obj; $tmp .= ',';
+
+=head2 Overloadable Operations
+
+The following symbols can be specified in C<use overload> directive:
+
+=over 5
+
+=item * I<Arithmetic operations>
+
+ "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=",
+ "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=",
+
+For these operations a substituted non-assignment variant can be called if
+the assignment variant is not available. Methods for operations C<+>,
+C<->, C<+=>, and C<-=> can be called to automatically generate
+increment and decrement methods. The operation C<-> can be used to
+autogenerate missing methods for unary minus or C<abs>.
+
+See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and
+L<"Calling Conventions for Binary Operations">) for details of these
+substitutions.
+
+=item * I<Comparison operations>
+
+ "<", "<=", ">", ">=", "==", "!=", "<=>",
+ "lt", "le", "gt", "ge", "eq", "ne", "cmp",
+
+If the corresponding "spaceship" variant is available, it can be
+used to substitute for the missing operation. During C<sort>ing
+arrays, C<cmp> is used to compare values subject to C<use overload>.
+
+=item * I<Bit operations>
+
+ "&", "&=", "^", "^=", "|", "|=", "neg", "!", "~",
+
+C<neg> stands for unary minus. If the method for C<neg> is not
+specified, it can be autogenerated using the method for
+subtraction. If the method for C<!> is not specified, it can be
+autogenerated using the methods for C<bool>, or C<"">, or C<0+>.
+
+The same remarks in L<"Arithmetic operations"> about
+assignment-variants and autogeneration apply for
+bit operations C<"&">, C<"^">, and C<"|"> as well.
+
+=item * I<Increment and decrement>
+
+ "++", "--",
+
+If undefined, addition and subtraction methods can be
+used instead. These operations are called both in prefix and
+postfix form.
+
+=item * I<Transcendental functions>
+
+ "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int"
+
+If C<abs> is unavailable, it can be autogenerated using methods
+for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
+
+Note that traditionally the Perl function L<int> rounds to 0, thus for
+floating-point-like types one should follow the same semantic. If
+C<int> is unavailable, it can be autogenerated using the overloading of
+C<0+>.
+
+=item * I<Boolean, string, numeric and regexp conversions>
+
+ 'bool', '""', '0+', 'qr'
+
+If one or two of these operations are not overloaded, the remaining ones
+can be used instead. C<bool> is used in the flow control operators
+(like C<while>) and for the ternary C<?:> operation; C<qr> is used for
+the RHS of C<=~> and when an object is interpolated into a regexp.
+
+C<bool>, C<"">, and C<0+> can return any arbitrary Perl value. If the
+corresponding operation for this value is overloaded too, that operation
+will be called again with this value. C<qr> must return a compiled
+regexp, or a ref to a compiled regexp (such as C<qr//> returns), and any
+further overloading on the return value will be ignored.
+
+As a special case if the overload returns the object itself then it will
+be used directly. An overloaded conversion returning the object is
+probably a bug, because you're likely to get something that looks like
+C<YourPackage=HASH(0x8172b34)>.
+
+=item * I<Iteration>
+
+ "<>"
+
+If not overloaded, the argument will be converted to a filehandle or
+glob (which may require a stringification). The same overloading
+happens both for the I<read-filehandle> syntax C<E<lt>$varE<gt>> and
+I<globbing> syntax C<E<lt>${var}E<gt>>.
+
+B<BUGS> Even in list context, the iterator is currently called only
+once and with scalar context.
+
+=item * I<File tests>
+
+ "-X"
+
+This overload is used for all the filetest operators (C<-f>, C<-x> and
+so on: see L<perlfunc/-X> for the full list). Even though these are
+unary operators, the method will be called with a second argument which
+is a single letter indicating which test was performed. Note that the
+overload key is the literal string C<"-X">: you can't provide separate
+overloads for the different tests.
+
+Calling an overloaded filetest operator does not affect the stat value
+associated with the special filehandle C<_>. It still refers to the
+result of the last C<stat>, C<lstat> or unoverloaded filetest.
+
+If not overloaded, these operators will fall back to the default
+behaviour even without C<< fallback => 1 >>. This means that if the
+object is a blessed glob or blessed IO ref it will be treated as a
+filehandle, otherwise string overloading will be invoked and the result
+treated as a filename.
+
+This overload was introduced in perl 5.12.
+
+=item * I<Matching>
+
+The key C<"~~"> allows you to override the smart matching logic used by
+the C<~~> operator and the switch construct (C<given>/C<when>). See
+L<perlsyn/switch> and L<feature>.
+
+Unusually, overloading of the smart match operator does not automatically
+take precedence over normal smart match behaviour. In particular, in the
+following code:
+
+ package Foo;
+ use overload '~~' => 'match';
+
+ my $obj = Foo->new();
+ $obj ~~ [ 1,2,3 ];
+
+the smart match does I<not> invoke the method call like this:
+
+ $obj->match([1,2,3],0);
+
+rather, the smart match distributive rule takes precedence, so $obj is
+smart matched against each array element in turn until a match is found,
+so you may see between one and three of these calls instead:
+
+ $obj->match(1,0);
+ $obj->match(2,0);
+ $obj->match(3,0);
+
+Consult the match table in L<perlsyn/"Smart matching in detail"> for
+details of when overloading is invoked.
+
+=item * I<Dereferencing>
+
+ '${}', '@{}', '%{}', '&{}', '*{}'.
+
+If not overloaded, the argument will be dereferenced I<as is>, thus
+should be of correct type. These functions should return a reference
+of correct type, or another object with overloaded dereferencing.
+
+As a special case if the overload returns the object itself then it
+will be used directly (provided it is the correct type).
+
+The dereference operators must be specified explicitly they will not be passed to
+"nomethod".
+
+=item * I<Special>
+
+ "nomethod", "fallback", "=".
+
+see L<SPECIAL SYMBOLS FOR C<use overload>>.
+
+=back
+
+See L<"Fallback"> for an explanation of when a missing method can be
+autogenerated.
+
+A computer-readable form of the above table is available in the hash
+%overload::ops, with values being space-separated lists of names:
+
+ with_assign => '+ - * / % ** << >> x .',
+ assign => '+= -= *= /= %= **= <<= >>= x= .=',
+ num_comparison => '< <= > >= == !=',
+ '3way_comparison'=> '<=> cmp',
+ str_comparison => 'lt le gt ge eq ne',
+ binary => '& &= | |= ^ ^=',
+ unary => 'neg ! ~',
+ mutators => '++ --',
+ func => 'atan2 cos sin exp abs log sqrt',
+ conversion => 'bool "" 0+ qr',
+ iterators => '<>',
+ filetest => '-X',
+ dereferencing => '${} @{} %{} &{} *{}',
+ matching => '~~',
+ special => 'nomethod fallback ='
+
+=head2 Inheritance and overloading
+
+Inheritance interacts with overloading in two ways.
+
+=over
+
+=item Strings as values of C<use overload> directive
+
+If C<value> in
+
+ use overload key => value;
+
+is a string, it is interpreted as a method name.
+
+=item Overloading of an operation is inherited by derived classes
+
+Any class derived from an overloaded class is also overloaded. The
+set of overloaded methods is the union of overloaded methods of all
+the ancestors. If some method is overloaded in several ancestor, then
+which description will be used is decided by the usual inheritance
+rules:
+
+If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads
+C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">,
+then the subroutine C<D::plus_sub> will be called to implement
+operation C<+> for an object in package C<A>.
+
+=back
+
+Note that since the value of the C<fallback> key is not a subroutine,
+its inheritance is not governed by the above rules. In the current
+implementation, the value of C<fallback> in the first overloaded
+ancestor is used, but this is accidental and subject to change.
+
+=head1 SPECIAL SYMBOLS FOR C<use overload>
+
+Three keys are recognized by Perl that are not covered by the above
+description.
+
+=head2 Last Resort
+
+C<"nomethod"> should be followed by a reference to a function of four
+parameters. If defined, it is called when the overloading mechanism
+cannot find a method for some operation. The first three arguments of
+this function coincide with the arguments for the corresponding method if
+it were found, the fourth argument is the symbol
+corresponding to the missing method. If several methods are tried,
+the last one is used. Say, C<1-$a> can be equivalent to
+
+ &nomethodMethod($a,1,1,"-")
+
+if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the
+C<use overload> directive.
+
+The C<"nomethod"> mechanism is I<not> used for the dereference operators
+( ${} @{} %{} &{} *{} ).
+
+
+If some operation cannot be resolved, and there is no function
+assigned to C<"nomethod">, then an exception will be raised via die()--
+unless C<"fallback"> was specified as a key in C<use overload> directive.
+
+
+=head2 Fallback
+
+The key C<"fallback"> governs what to do if a method for a particular
+operation is not found. Three different cases are possible depending on
+the value of C<"fallback">:
+
+=over 16
+
+=item * C<undef>
+
+Perl tries to use a
+substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it
+then tries to calls C<"nomethod"> value; if missing, an exception
+will be raised.
+
+=item * TRUE
+
+The same as for the C<undef> value, but no exception is raised. Instead,
+it silently reverts to what it would have done were there no C<use overload>
+present.
+
+=item * defined, but FALSE
+
+No autogeneration is tried. Perl tries to call
+C<"nomethod"> value, and if this is missing, raises an exception.
+
+=back
+
+B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone
+yet, see L<"Inheritance and overloading">.
+
+=head2 Copy Constructor
+
+The value for C<"="> is a reference to a function with three
+arguments, i.e., it looks like the other values in C<use
+overload>. However, it does not overload the Perl assignment
+operator. This would go against Camel hair.
+
+This operation is called in the situations when a mutator is applied
+to a reference that shares its object with some other reference, such
+as
+
+ $a=$b;
+ ++$a;
+
+To make this change $a and not change $b, a copy of C<$$a> is made,
+and $a is assigned a reference to this new object. This operation is
+done during execution of the C<++$a>, and not during the assignment,
+(so before the increment C<$$a> coincides with C<$$b>). This is only
+done if C<++> is expressed via a method for C<'++'> or C<'+='> (or
+C<nomethod>). Note that if this operation is expressed via C<'+'>
+a nonmutator, i.e., as in
+
+ $a=$b;
+ $a=$a+1;
+
+then C<$a> does not reference a new copy of C<$$a>, since $$a does not
+appear as lvalue when the above code is executed.
+
+If the copy constructor is required during the execution of some mutator,
+but a method for C<'='> was not specified, it can be autogenerated as a
+string copy if the object is a plain scalar or a simple assignment if it
+is not.
+
+=over 5
+
+=item B<Example>
+
+The actually executed code for
+
+ $a=$b;
+ Something else which does not modify $a or $b....
+ ++$a;
+
+may be
+
+ $a=$b;
+ Something else which does not modify $a or $b....
+ $a = $a->clone(undef,"");
+ $a->incr(undef,"");
+
+if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>,
+C<'='> was overloaded with C<\&clone>.
+
+=back
+
+Same behaviour is triggered by C<$b = $a++>, which is consider a synonym for
+C<$b = $a; ++$a>.
+
+=head1 MAGIC AUTOGENERATION
+
+If a method for an operation is not found, and the value for C<"fallback"> is
+TRUE or undefined, Perl tries to autogenerate a substitute method for
+the missing operation based on the defined operations. Autogenerated method
+substitutions are possible for the following operations:
+
+=over 16
+
+=item I<Assignment forms of arithmetic operations>
+
+C<$a+=$b> can use the method for C<"+"> if the method for C<"+=">
+is not defined.
+
+=item I<Conversion operations>
+
+String, numeric, boolean and regexp conversions are calculated in terms
+of one another if not all of them are defined.
+
+=item I<Increment and decrement>
+
+The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>,
+and C<$a--> in terms of C<$a-=1> and C<$a-1>.
+
+=item C<abs($a)>
+
+can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>).
+
+=item I<Unary minus>
+
+can be expressed in terms of subtraction.
+
+=item I<Negation>
+
+C<!> and C<not> can be expressed in terms of boolean conversion, or
+string or numerical conversion.
+
+=item I<Concatenation>
+
+can be expressed in terms of string conversion.
+
+=item I<Comparison operations>
+
+can be expressed in terms of its "spaceship" counterpart: either
+C<E<lt>=E<gt>> or C<cmp>:
+
+ <, >, <=, >=, ==, != in terms of <=>
+ lt, gt, le, ge, eq, ne in terms of cmp
+
+=item I<Iterator>
+
+ <> in terms of builtin operations
+
+=item I<Dereferencing>
+
+ ${} @{} %{} &{} *{} in terms of builtin operations
+
+=item I<Copy operator>
+
+can be expressed in terms of an assignment to the dereferenced value, if this
+value is a scalar and not a reference, or simply a reference assignment
+otherwise.
+
+=back
+
+=head1 Minimal set of overloaded operations
+
+Since some operations can be automatically generated from others, there is
+a minimal set of operations that need to be overloaded in order to have
+the complete set of overloaded operations at one's disposal.
+Of course, the autogenerated operations may not do exactly what the user
+expects. See L<MAGIC AUTOGENERATION> above. The minimal set is:
+
+ + - * / % ** << >> x
+ <=> cmp
+ & | ^ ~
+ atan2 cos sin exp log sqrt int
+
+Additionally, you need to define at least one of string, boolean or
+numeric conversions because any one can be used to emulate the others.
+The string conversion can also be used to emulate concatenation.
+
+=head1 Losing overloading
+
+The restriction for the comparison operation is that even if, for example,
+`C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
+function will produce only a standard logical value based on the
+numerical value of the result of `C<cmp>'. In particular, a working
+numeric conversion is needed in this case (possibly expressed in terms of
+other conversions).
+
+Similarly, C<.=> and C<x=> operators lose their mathemagical properties
+if the string conversion substitution is applied.
+
+When you chop() a mathemagical object it is promoted to a string and its
+mathemagical properties are lost. The same can happen with other
+operations as well.
+
+=head1 Run-time Overloading
+
+Since all C<use> directives are executed at compile-time, the only way to
+change overloading during run-time is to
+
+ eval 'use overload "+" => \&addmethod';
+
+You can also use
+
+ eval 'no overload "+", "--", "<="';
+
+though the use of these constructs during run-time is questionable.
+
+=head1 Public functions
+
+Package C<overload.pm> provides the following public functions:
+
+=over 5
+
+=item overload::StrVal(arg)
+
+Gives string value of C<arg> as in absence of stringify overloading. If you
+are using this to get the address of a reference (useful for checking if two
+references point to the same thing) then you may be better off using
+C<Scalar::Util::refaddr()>, which is faster.
+
+=item overload::Overloaded(arg)
+
+Returns true if C<arg> is subject to overloading of some operations.
+
+=item overload::Method(obj,op)
+
+Returns C<undef> or a reference to the method that implements C<op>.
+
+=back
+
+=head1 Overloading constants
+
+For some applications, the Perl parser mangles constants too much.
+It is possible to hook into this process via C<overload::constant()>
+and C<overload::remove_constant()> functions.
+
+These functions take a hash as an argument. The recognized keys of this hash
+are:
+
+=over 8
+
+=item integer
+
+to overload integer constants,
+
+=item float
+
+to overload floating point constants,
+
+=item binary
+
+to overload octal and hexadecimal constants,
+
+=item q
+
+to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted
+strings and here-documents,
+
+=item qr
+
+to overload constant pieces of regular expressions.
+
+=back
+
+The corresponding values are references to functions which take three arguments:
+the first one is the I<initial> string form of the constant, the second one
+is how Perl interprets this constant, the third one is how the constant is used.
+Note that the initial string form does not
+contain string delimiters, and has backslashes in backslash-delimiter
+combinations stripped (thus the value of delimiter is not relevant for
+processing of this string). The return value of this function is how this
+constant is going to be interpreted by Perl. The third argument is undefined
+unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote
+context (comes from strings, regular expressions, and single-quote HERE
+documents), it is C<tr> for arguments of C<tr>/C<y> operators,
+it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise.
+
+Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>,
+it is expected that overloaded constant strings are equipped with reasonable
+overloaded catenation operator, otherwise absurd results will result.
+Similarly, negative numbers are considered as negations of positive constants.
+
+Note that it is probably meaningless to call the functions overload::constant()
+and overload::remove_constant() from anywhere but import() and unimport() methods.
+From these methods they may be called as
+
+ sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant integer => sub {Math::BigInt->new(shift)};
+ }
+
+=head1 IMPLEMENTATION
+
+What follows is subject to change RSN.
+
+The table of methods for all operations is cached in magic for the
+symbol table hash for the package. The cache is invalidated during
+processing of C<use overload>, C<no overload>, new function
+definitions, and changes in @ISA. However, this invalidation remains
+unprocessed until the next C<bless>ing into the package. Hence if you
+want to change overloading structure dynamically, you'll need an
+additional (fake) C<bless>ing to update the table.
+
+(Every SVish thing has a magic queue, and magic is an entry in that
+queue. This is how a single variable may participate in multiple
+forms of magic simultaneously. For instance, environment variables
+regularly have two forms at once: their %ENV magic and their taint
+magic. However, the magic which implements overloading is applied to
+the stashes, which are rarely used directly, thus should not slow down
+Perl.)
+
+If an object belongs to a package using overload, it carries a special
+flag. Thus the only speed penalty during arithmetic operations without
+overloading is the checking of this flag.
+
+In fact, if C<use overload> is not present, there is almost no overhead
+for overloadable operations, so most programs should not suffer
+measurable performance penalties. A considerable effort was made to
+minimize the overhead when overload is used in some package, but the
+arguments in question do not belong to packages using overload. When
+in doubt, test your speed with C<use overload> and without it. So far
+there have been no reports of substantial speed degradation if Perl is
+compiled with optimization turned on.
+
+There is no size penalty for data if overload is not used. The only
+size penalty if overload is used in some package is that I<all> the
+packages acquire a magic during the next C<bless>ing into the
+package. This magic is three-words-long for packages without
+overloading, and carries the cache table if the package is overloaded.
+
+Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is
+carried out before any operation that can imply an assignment to the
+object $a (or $b) refers to, like C<$a++>. You can override this
+behavior by defining your own copy constructor (see L<"Copy Constructor">).
+
+It is expected that arguments to methods that are not explicitly supposed
+to be changed are constant (but this is not enforced).
+
+=head1 Metaphor clash
+
+One may wonder why the semantic of overloaded C<=> is so counter intuitive.
+If it I<looks> counter intuitive to you, you are subject to a metaphor
+clash.
+
+Here is a Perl object metaphor:
+
+I< object is a reference to blessed data>
+
+and an arithmetic metaphor:
+
+I< object is a thing by itself>.
+
+The I<main> problem of overloading C<=> is the fact that these metaphors
+imply different actions on the assignment C<$a = $b> if $a and $b are
+objects. Perl-think implies that $a becomes a reference to whatever
+$b was referencing. Arithmetic-think implies that the value of "object"
+$a is changed to become the value of the object $b, preserving the fact
+that $a and $b are separate entities.
+
+The difference is not relevant in the absence of mutators. After
+a Perl-way assignment an operation which mutates the data referenced by $a
+would change the data referenced by $b too. Effectively, after
+C<$a = $b> values of $a and $b become I<indistinguishable>.
+
+On the other hand, anyone who has used algebraic notation knows the
+expressive power of the arithmetic metaphor. Overloading works hard
+to enable this metaphor while preserving the Perlian way as far as
+possible. Since it is not possible to freely mix two contradicting
+metaphors, overloading allows the arithmetic way to write things I<as
+far as all the mutators are called via overloaded access only>. The
+way it is done is described in L<Copy Constructor>.
+
+If some mutator methods are directly applied to the overloaded values,
+one may need to I<explicitly unlink> other values which references the
+same value:
+
+ $a = Data->new(23);
+ ...
+ $b = $a; # $b is "linked" to $a
+ ...
+ $a = $a->clone; # Unlink $b from $a
+ $a->increment_by(4);
+
+Note that overloaded access makes this transparent:
+
+ $a = Data->new(23);
+ $b = $a; # $b is "linked" to $a
+ $a += 4; # would unlink $b automagically
+
+However, it would not make
+
+ $a = Data->new(23);
+ $a = 4; # Now $a is a plain 4, not 'Data'
+
+preserve "objectness" of $a. But Perl I<has> a way to make assignments
+to an object do whatever you want. It is just not the overload, but
+tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method
+which returns the object itself, and STORE() method which changes the
+value of the object, one can reproduce the arithmetic metaphor in its
+completeness, at least for variables which were tie()d from the start.
+
+(Note that a workaround for a bug may be needed, see L<"BUGS">.)
+
+=head1 Cookbook
+
+Please add examples to what follows!
+
+=head2 Two-face scalars
+
+Put this in F<two_face.pm> in your Perl library directory:
+
+ package two_face; # Scalars with separate string and
+ # numeric values.
+ sub new { my $p = shift; bless [@_], $p }
+ use overload '""' => \&str, '0+' => \&num, fallback => 1;
+ sub num {shift->[1]}
+ sub str {shift->[0]}
+
+Use it as follows:
+
+ require two_face;
+ my $seven = two_face->new("vii", 7);
+ printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1;
+ print "seven contains `i'\n" if $seven =~ /i/;
+
+(The second line creates a scalar which has both a string value, and a
+numeric value.) This prints:
+
+ seven=vii, seven=7, eight=8
+ seven contains `i'
+
+=head2 Two-face references
+
+Suppose you want to create an object which is accessible as both an
+array reference and a hash reference.
+
+ package two_refs;
+ use overload '%{}' => \&gethash, '@{}' => sub { $ {shift()} };
+ sub new {
+ my $p = shift;
+ bless \ [@_], $p;
+ }
+ sub gethash {
+ my %h;
+ my $self = shift;
+ tie %h, ref $self, $self;
+ \%h;
+ }
+
+ sub TIEHASH { my $p = shift; bless \ shift, $p }
+ my %fields;
+ my $i = 0;
+ $fields{$_} = $i++ foreach qw{zero one two three};
+ sub STORE {
+ my $self = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $$self->[$key] = shift;
+ }
+ sub FETCH {
+ my $self = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $$self->[$key];
+ }
+
+Now one can access an object using both the array and hash syntax:
+
+ my $bar = two_refs->new(3,4,5,6);
+ $bar->[2] = 11;
+ $bar->{two} == 11 or die 'bad hash fetch';
+
+Note several important features of this example. First of all, the
+I<actual> type of $bar is a scalar reference, and we do not overload
+the scalar dereference. Thus we can get the I<actual> non-overloaded
+contents of $bar by just using C<$$bar> (what we do in functions which
+overload dereference). Similarly, the object returned by the
+TIEHASH() method is a scalar reference.
+
+Second, we create a new tied hash each time the hash syntax is used.
+This allows us not to worry about a possibility of a reference loop,
+which would lead to a memory leak.
+
+Both these problems can be cured. Say, if we want to overload hash
+dereference on a reference to an object which is I<implemented> as a
+hash itself, the only problem one has to circumvent is how to access
+this I<actual> hash (as opposed to the I<virtual> hash exhibited by the
+overloaded dereference operator). Here is one possible fetching routine:
+
+ sub access_hash {
+ my ($self, $key) = (shift, shift);
+ my $class = ref $self;
+ bless $self, 'overload::dummy'; # Disable overloading of %{}
+ my $out = $self->{$key};
+ bless $self, $class; # Restore overloading
+ $out;
+ }
+
+To remove creation of the tied hash on each access, one may an extra
+level of indirection which allows a non-circular structure of references:
+
+ package two_refs1;
+ use overload '%{}' => sub { ${shift()}->[1] },
+ '@{}' => sub { ${shift()}->[0] };
+ sub new {
+ my $p = shift;
+ my $a = [@_];
+ my %h;
+ tie %h, $p, $a;
+ bless \ [$a, \%h], $p;
+ }
+ sub gethash {
+ my %h;
+ my $self = shift;
+ tie %h, ref $self, $self;
+ \%h;
+ }
+
+ sub TIEHASH { my $p = shift; bless \ shift, $p }
+ my %fields;
+ my $i = 0;
+ $fields{$_} = $i++ foreach qw{zero one two three};
+ sub STORE {
+ my $a = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $a->[$key] = shift;
+ }
+ sub FETCH {
+ my $a = ${shift()};
+ my $key = $fields{shift()};
+ defined $key or die "Out of band access";
+ $a->[$key];
+ }
+
+Now if $baz is overloaded like this, then C<$baz> is a reference to a
+reference to the intermediate array, which keeps a reference to an
+actual array, and the access hash. The tie()ing object for the access
+hash is a reference to a reference to the actual array, so
+
+=over
+
+=item *
+
+There are no loops of references.
+
+=item *
+
+Both "objects" which are blessed into the class C<two_refs1> are
+references to a reference to an array, thus references to a I<scalar>.
+Thus the accessor expression C<$$foo-E<gt>[$ind]> involves no
+overloaded operations.
+
+=back
+
+=head2 Symbolic calculator
+
+Put this in F<symbolic.pm> in your Perl library directory:
+
+ package symbolic; # Primitive symbolic calculator
+ use overload nomethod => \&wrap;
+
+ sub new { shift; bless ['n', @_] }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+
+This module is very unusual as overloaded modules go: it does not
+provide any usual overloaded operators, instead it provides the L<Last
+Resort> operator C<nomethod>. In this example the corresponding
+subroutine returns an object which encapsulates operations done over
+the objects: C<< symbolic->new(3) >> contains C<['n', 3]>, C<< 2 +
+symbolic->new(3) >> contains C<['+', 2, ['n', 3]]>.
+
+Here is an example of the script which "calculates" the side of
+circumscribed octagon using the above package:
+
+ require symbolic;
+ my $iter = 1; # 2**($iter+2) = 8
+ my $side = symbolic->new(1);
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ print "OK\n";
+
+The value of $side is
+
+ ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]],
+ undef], 1], ['n', 1]]
+
+Note that while we obtained this value using a nice little script,
+there is no simple way to I<use> this value. In fact this value may
+be inspected in debugger (see L<perldebug>), but only if
+C<bareStringify> B<O>ption is set, and not via C<p> command.
+
+If one attempts to print this value, then the overloaded operator
+C<""> will be called, which will call C<nomethod> operator. The
+result of this operator will be stringified again, but this result is
+again of type C<symbolic>, which will lead to an infinite loop.
+
+Add a pretty-printer method to the module F<symbolic.pm>:
+
+ sub pretty {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ $b = 'u' unless defined $b;
+ $a = $a->pretty if ref $a;
+ $b = $b->pretty if ref $b;
+ "[$meth $a $b]";
+ }
+
+Now one can finish the script by
+
+ print "side = ", $side->pretty, "\n";
+
+The method C<pretty> is doing object-to-string conversion, so it
+is natural to overload the operator C<""> using this method. However,
+inside such a method it is not necessary to pretty-print the
+I<components> $a and $b of an object. In the above subroutine
+C<"[$meth $a $b]"> is a catenation of some strings and components $a
+and $b. If these components use overloading, the catenation operator
+will look for an overloaded operator C<.>; if not present, it will
+look for an overloaded operator C<"">. Thus it is enough to use
+
+ use overload nomethod => \&wrap, '""' => \&str;
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ $b = 'u' unless defined $b;
+ "[$meth $a $b]";
+ }
+
+Now one can change the last line of the script to
+
+ print "side = $side\n";
+
+which outputs
+
+ side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]]
+
+and one can inspect the value in debugger using all the possible
+methods.
+
+Something is still amiss: consider the loop variable $cnt of the
+script. It was a number, not an object. We cannot make this value of
+type C<symbolic>, since then the loop will not terminate.
+
+Indeed, to terminate the cycle, the $cnt should become false.
+However, the operator C<bool> for checking falsity is overloaded (this
+time via overloaded C<"">), and returns a long string, thus any object
+of type C<symbolic> is true. To overcome this, we need a way to
+compare an object to 0. In fact, it is easier to write a numeric
+conversion routine.
+
+Here is the text of F<symbolic.pm> with such a routine added (and
+slightly modified str()):
+
+ package symbolic; # Primitive symbolic calculator
+ use overload
+ nomethod => \&wrap, '""' => \&str, '0+' => \&num;
+
+ sub new { shift; bless ['n', @_] }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( n => sub {$_[0]},
+ sqrt => sub {sqrt $_[0]},
+ '-' => sub {shift() - shift()},
+ '+' => sub {shift() + shift()},
+ '/' => sub {shift() / shift()},
+ '*' => sub {shift() * shift()},
+ '**' => sub {shift() ** shift()},
+ );
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+
+All the work of numeric conversion is done in %subr and num(). Of
+course, %subr is not complete, it contains only operators used in the
+example below. Here is the extra-credit question: why do we need an
+explicit recursion in num()? (Answer is at the end of this section.)
+
+Use this module like this:
+
+ require symbolic;
+ my $iter = symbolic->new(2); # 16-gon
+ my $side = symbolic->new(1);
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # Mutator `--' not implemented
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ printf "%s=%f\n", $side, $side;
+ printf "pi=%f\n", $side*(2**($iter+2));
+
+It prints (without so many line breaks)
+
+ [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1]
+ [n 1]] 2]]] 1]
+ [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912
+ pi=3.182598
+
+The above module is very primitive. It does not implement
+mutator methods (C<++>, C<-=> and so on), does not do deep copying
+(not required without mutators!), and implements only those arithmetic
+operations which are used in the example.
+
+To implement most arithmetic operations is easy; one should just use
+the tables of operations, and change the code which fills %subr to
+
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ print "defining `$op'\n";
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+
+Due to L<Calling Conventions for Mutators>, we do not need anything
+special to make C<+=> and friends work, except filling C<+=> entry of
+%subr, and defining a copy constructor (needed since Perl has no
+way to know that the implementation of C<'+='> does not mutate
+the argument, compare L<Copy Constructor>).
+
+To implement a copy constructor, add C<< '=' => \&cpy >> to C<use overload>
+line, and code (this code assumes that mutators change things one level
+deep only, so recursive copying is not needed):
+
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+
+To make C<++> and C<--> work, we need to implement actual mutators,
+either directly, or in C<nomethod>. We continue to do things inside
+C<nomethod>, thus add
+
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+
+after the first line of wrap(). This is not a most effective
+implementation, one may consider
+
+ sub inc { $_[0] = bless ['++', shift, 1]; }
+
+instead.
+
+As a final remark, note that one can fill %subr by
+
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+This finishes implementation of a primitive symbolic calculator in
+50 lines of Perl code. Since the numeric values of subexpressions
+are not cached, the calculator is very slow.
+
+Here is the answer for the exercise: In the case of str(), we need no
+explicit recursion since the overloaded C<.>-operator will fall back
+to an existing overloaded operator C<"">. Overloaded arithmetic
+operators I<do not> fall back to numeric conversion if C<fallback> is
+not explicitly requested. Thus without an explicit recursion num()
+would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild
+the argument of num().
+
+If you wonder why defaults for conversion are different for str() and
+num(), note how easy it was to write the symbolic calculator. This
+simplicity is due to an appropriate choice of defaults. One extra
+note: due to the explicit recursion num() is more fragile than sym():
+we need to explicitly check for the type of $a and $b. If components
+$a and $b happen to be of some related type, this may lead to problems.
+
+=head2 I<Really> symbolic calculator
+
+One may wonder why we call the above calculator symbolic. The reason
+is that the actual calculation of the value of expression is postponed
+until the value is I<used>.
+
+To see it in action, add a method
+
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ @$obj->[0,1] = ('=', shift);
+ }
+
+to the package C<symbolic>. After this change one can do
+
+ my $a = symbolic->new(3);
+ my $b = symbolic->new(4);
+ my $c = sqrt($a**2 + $b**2);
+
+and the numeric value of $c becomes 5. However, after calling
+
+ $a->STORE(12); $b->STORE(5);
+
+the numeric value of $c becomes 13. There is no doubt now that the module
+symbolic provides a I<symbolic> calculator indeed.
+
+To hide the rough edges under the hood, provide a tie()d interface to the
+package C<symbolic> (compare with L<Metaphor clash>). Add methods
+
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+
+(the bug is described in L<"BUGS">). One can use this new interface as
+
+ tie $a, 'symbolic', 3;
+ tie $b, 'symbolic', 4;
+ $a->nop; $b->nop; # Around a bug
+
+ my $c = sqrt($a**2 + $b**2);
+
+Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value
+of $c becomes 13. To insulate the user of the module add a method
+
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+
+Now
+
+ my ($a, $b);
+ symbolic->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+
+ $a = 3; $b = 4;
+ printf "c5 %s=%f\n", $c, $c;
+
+ $a = 12; $b = 5;
+ printf "c13 %s=%f\n", $c, $c;
+
+shows that the numeric value of $c follows changes to the values of $a
+and $b.
+
+=head1 AUTHOR
+
+Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>.
+
+=head1 SEE ALSO
+
+The L<overloading> pragma can be used to enable or disable overloaded
+operations within a lexical scope.
+
+=head1 DIAGNOSTICS
+
+When Perl is run with the B<-Do> switch or its equivalent, overloading
+induces diagnostic messages.
+
+Using the C<m> command of Perl debugger (see L<perldebug>) one can
+deduce which operations are overloaded (and which ancestor triggers
+this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
+is shown by debugger. The method C<()> corresponds to the C<fallback>
+key (in fact a presence of this method shows that this package has
+overloading enabled, and it is what is used by the C<Overloaded>
+function of module C<overload>).
+
+The module might issue the following warnings:
+
+=over 4
+
+=item Odd number of arguments for overload::constant
+
+(W) The call to overload::constant contained an odd number of arguments.
+The arguments should come in pairs.
+
+=item `%s' is not an overloadable type
+
+(W) You tried to overload a constant type the overload package is unaware of.
+
+=item `%s' is not a code reference
+
+(W) The second (fourth, sixth, ...) argument of overload::constant needs
+to be a code reference. Either an anonymous subroutine, or a reference
+to a subroutine.
+
+=back
+
+=head1 BUGS
+
+Because it is used for overloading, the per-package hash %OVERLOAD now
+has a special meaning in Perl. The symbol table is filled with names
+looking like line-noise.
+
+For the purpose of inheritance every overloaded package behaves as if
+C<fallback> is present (possibly undefined). This may create
+interesting effects if some package is not overloaded, but inherits
+from two overloaded packages.
+
+Relation between overloading and tie()ing is broken. Overloading is
+triggered or not basing on the I<previous> class of tie()d value.
+
+This happens because the presence of overloading is checked too early,
+before any tie()d access is attempted. If the FETCH()ed class of the
+tie()d value does not change, a simple workaround is to access the value
+immediately after tie()ing, so that after this call the I<previous> class
+coincides with the current one.
+
+B<Needed:> a way to fix this without a speed penalty.
+
+Barewords are not covered by overloaded string constants.
+
+This document is confusing. There are grammos and misleading language
+used in places. It would seem a total rewrite is needed.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/overloading.pm b/Master/tlpkg/tlperl/lib/overloading.pm
new file mode 100644
index 00000000000..d1ca5664b6c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/overloading.pm
@@ -0,0 +1,101 @@
+package overloading;
+use warnings;
+
+use Carp ();
+
+our $VERSION = '0.01';
+
+my $HINT_NO_AMAGIC = 0x01000000; # see perl.h
+
+require 5.010001;
+
+sub _ops_to_nums {
+ require overload::numbers;
+
+ map { exists $overload::numbers::names{"($_"}
+ ? $overload::numbers::names{"($_"}
+ : Carp::croak("'$_' is not a valid overload")
+ } @_;
+}
+
+sub import {
+ my ( $class, @ops ) = @_;
+
+ if ( @ops ) {
+ if ( $^H{overloading} ) {
+ vec($^H{overloading} , $_, 1) = 0 for _ops_to_nums(@ops);
+ }
+
+ if ( $^H{overloading} !~ /[^\0]/ ) {
+ delete $^H{overloading};
+ $^H &= ~$HINT_NO_AMAGIC;
+ }
+ } else {
+ delete $^H{overloading};
+ $^H &= ~$HINT_NO_AMAGIC;
+ }
+}
+
+sub unimport {
+ my ( $class, @ops ) = @_;
+
+ if ( exists $^H{overloading} or not $^H & $HINT_NO_AMAGIC ) {
+ if ( @ops ) {
+ vec($^H{overloading} ||= '', $_, 1) = 1 for _ops_to_nums(@ops);
+ } else {
+ delete $^H{overloading};
+ }
+ }
+
+ $^H |= $HINT_NO_AMAGIC;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+overloading - perl pragma to lexically control overloading
+
+=head1 SYNOPSIS
+
+ {
+ no overloading;
+ my $str = "$object"; # doesn't call stringification overload
+ }
+
+ # it's lexical, so this stringifies:
+ warn "$object";
+
+ # it can be enabled per op
+ no overloading qw("");
+ warn "$object";
+
+ # and also reenabled
+ use overloading;
+
+=head1 DESCRIPTION
+
+This pragma allows you to lexically disable or enable overloading.
+
+=over 6
+
+=item C<no overloading>
+
+Disables overloading entirely in the current lexical scope.
+
+=item C<no overloading @ops>
+
+Disables only specific overloads in the current lexical scope.
+
+=item C<use overloading>
+
+Reenables overloading in the current lexical scope.
+
+=item C<use overloading @ops>
+
+Reenables overloading only for specific ops in the current lexical scope.
+
+=back
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/parent.pm b/Master/tlpkg/tlperl/lib/parent.pm
new file mode 100644
index 00000000000..a18526bb519
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/parent.pm
@@ -0,0 +1,136 @@
+package parent;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.223';
+
+sub import {
+ my $class = shift;
+
+ my $inheritor = caller(0);
+
+ if ( @_ and $_[0] eq '-norequire' ) {
+ shift @_;
+ } else {
+ for ( my @filename = @_ ) {
+ if ( $_ eq $inheritor ) {
+ warn "Class '$inheritor' tried to inherit from itself\n";
+ };
+
+ s{::|'}{/}g;
+ require "$_.pm"; # dies if the file is not found
+ }
+ }
+
+ {
+ no strict 'refs';
+ # This is more efficient than push for the new MRO
+ # at least until the new MRO is fixed
+ @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , @_);
+ };
+};
+
+"All your base are belong to us"
+
+__END__
+
+=head1 NAME
+
+parent - Establish an ISA relationship with base classes at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use parent qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Allows you to both load one or more modules, while setting up inheritance from
+those modules at the same time. Mostly similar in effect to
+
+ package Baz;
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+By default, every base class needs to live in a file of its own.
+If you want to have a subclass and its parent class in the same file, you
+can tell C<parent> not to load any modules by using the C<-norequire> switch:
+
+ package Foo;
+ sub exclaim { "I CAN HAS PERL" }
+
+ package DoesNotLoadFooBar;
+ use parent -norequire, 'Foo', 'Bar';
+ # will not go looking for Foo.pm or Bar.pm
+
+This is equivalent to the following code:
+
+ package Foo;
+ sub exclaim { "I CAN HAS PERL" }
+
+ package DoesNotLoadFooBar;
+ push @DoesNotLoadFooBar::ISA, 'Foo', 'Bar';
+
+This is also helpful for the case where a package lives within
+a differently named file:
+
+ package MyHash;
+ use Tie::Hash;
+ use parent -norequire, 'Tie::StdHash';
+
+This is equivalent to the following code:
+
+ package MyHash;
+ require Tie::Hash;
+ push @ISA, 'Tie::StdHash';
+
+If you want to load a subclass from a file that C<require> would
+not consider an eligible filename (that is, it does not end in
+either C<.pm> or C<.pmc>), use the following code:
+
+ package MySecondPlugin;
+ require './plugins/custom.plugin'; # contains Plugin::Custom
+ use parent -norequire, 'Plugin::Custom';
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item Class 'Foo' tried to inherit from itself
+
+Attempting to inherit from yourself generates a warning.
+
+ use Foo;
+ use parent 'Foo';
+
+=back
+
+=head1 HISTORY
+
+This module was forked from L<base> to remove the cruft
+that had accumulated in it.
+
+=head1 CAVEATS
+
+=head1 SEE ALSO
+
+L<base>
+
+=head1 AUTHORS AND CONTRIBUTORS
+
+Rafaël Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern
+
+=head1 MAINTAINER
+
+Max Maischein C< corion@cpan.org >
+
+Copyright (c) 2007 Max Maischein C<< <corion@cpan.org> >>
+Based on the idea of C<base.pm>, which was introduced with Perl 5.004_04.
+
+=head1 LICENSE
+
+This module is released under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/perl5db.pl b/Master/tlpkg/tlperl/lib/perl5db.pl
new file mode 100644
index 00000000000..b3daaf55abd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/perl5db.pl
@@ -0,0 +1,9559 @@
+
+=head1 NAME
+
+perl5db.pl - the perl debugger
+
+=head1 SYNOPSIS
+
+ perl -d your_Perl_script
+
+=head1 DESCRIPTION
+
+C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
+you invoke a script with C<perl -d>. This documentation tries to outline the
+structure and services provided by C<perl5db.pl>, and to describe how you
+can use them.
+
+=head1 GENERAL NOTES
+
+The debugger can look pretty forbidding to many Perl programmers. There are
+a number of reasons for this, many stemming out of the debugger's history.
+
+When the debugger was first written, Perl didn't have a lot of its nicer
+features - no references, no lexical variables, no closures, no object-oriented
+programming. So a lot of the things one would normally have done using such
+features was done using global variables, globs and the C<local()> operator
+in creative ways.
+
+Some of these have survived into the current debugger; a few of the more
+interesting and still-useful idioms are noted in this section, along with notes
+on the comments themselves.
+
+=head2 Why not use more lexicals?
+
+Experienced Perl programmers will note that the debugger code tends to use
+mostly package globals rather than lexically-scoped variables. This is done
+to allow a significant amount of control of the debugger from outside the
+debugger itself.
+
+Unfortunately, though the variables are accessible, they're not well
+documented, so it's generally been a decision that hasn't made a lot of
+difference to most users. Where appropriate, comments have been added to
+make variables more accessible and usable, with the understanding that these
+I<are> debugger internals, and are therefore subject to change. Future
+development should probably attempt to replace the globals with a well-defined
+API, but for now, the variables are what we've got.
+
+=head2 Automated variable stacking via C<local()>
+
+As you may recall from reading C<perlfunc>, the C<local()> operator makes a
+temporary copy of a variable in the current scope. When the scope ends, the
+old copy is restored. This is often used in the debugger to handle the
+automatic stacking of variables during recursive calls:
+
+ sub foo {
+ local $some_global++;
+
+ # Do some stuff, then ...
+ return;
+ }
+
+What happens is that on entry to the subroutine, C<$some_global> is localized,
+then altered. When the subroutine returns, Perl automatically undoes the
+localization, restoring the previous value. Voila, automatic stack management.
+
+The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
+which lets the debugger get control inside of C<eval>'ed code. The debugger
+localizes a saved copy of C<$@> inside the subroutine, which allows it to
+keep C<$@> safe until it C<DB::eval> returns, at which point the previous
+value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
+track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
+
+In any case, watch for this pattern. It occurs fairly often.
+
+=head2 The C<^> trick
+
+This is used to cleverly reverse the sense of a logical test depending on
+the value of an auxiliary variable. For instance, the debugger's C<S>
+(search for subroutines by pattern) allows you to negate the pattern
+like this:
+
+ # Find all non-'foo' subs:
+ S !/foo/
+
+Boolean algebra states that the truth table for XOR looks like this:
+
+=over 4
+
+=item * 0 ^ 0 = 0
+
+(! not present and no match) --> false, don't print
+
+=item * 0 ^ 1 = 1
+
+(! not present and matches) --> true, print
+
+=item * 1 ^ 0 = 1
+
+(! present and no match) --> true, print
+
+=item * 1 ^ 1 = 0
+
+(! present and matches) --> false, don't print
+
+=back
+
+As you can see, the first pair applies when C<!> isn't supplied, and
+the second pair applies when it is. The XOR simply allows us to
+compact a more complicated if-then-elseif-else into a more elegant
+(but perhaps overly clever) single test. After all, it needed this
+explanation...
+
+=head2 FLAGS, FLAGS, FLAGS
+
+There is a certain C programming legacy in the debugger. Some variables,
+such as C<$single>, C<$trace>, and C<$frame>, have I<magical> values composed
+of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
+of state to be stored independently in a single scalar.
+
+A test like
+
+ if ($scalar & 4) ...
+
+is checking to see if the appropriate bit is on. Since each bit can be
+"addressed" independently in this way, C<$scalar> is acting sort of like
+an array of bits. Obviously, since the contents of C<$scalar> are just a
+bit-pattern, we can save and restore it easily (it will just look like
+a number).
+
+The problem, is of course, that this tends to leave magic numbers scattered
+all over your program whenever a bit is set, cleared, or checked. So why do
+it?
+
+=over 4
+
+=item *
+
+First, doing an arithmetical or bitwise operation on a scalar is
+just about the fastest thing you can do in Perl: C<use constant> actually
+creates a subroutine call, and array and hash lookups are much slower. Is
+this over-optimization at the expense of readability? Possibly, but the
+debugger accesses these variables a I<lot>. Any rewrite of the code will
+probably have to benchmark alternate implementations and see which is the
+best balance of readability and speed, and then document how it actually
+works.
+
+=item *
+
+Second, it's very easy to serialize a scalar number. This is done in
+the restart code; the debugger state variables are saved in C<%ENV> and then
+restored when the debugger is restarted. Having them be just numbers makes
+this trivial.
+
+=item *
+
+Third, some of these variables are being shared with the Perl core
+smack in the middle of the interpreter's execution loop. It's much faster for
+a C program (like the interpreter) to check a bit in a scalar than to access
+several different variables (or a Perl array).
+
+=back
+
+=head2 What are those C<XXX> comments for?
+
+Any comment containing C<XXX> means that the comment is either somewhat
+speculative - it's not exactly clear what a given variable or chunk of
+code is doing, or that it is incomplete - the basics may be clear, but the
+subtleties are not completely documented.
+
+Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
+
+=head1 DATA STRUCTURES MAINTAINED BY CORE
+
+There are a number of special data structures provided to the debugger by
+the Perl interpreter.
+
+The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob
+assignment) contains the text from C<$filename>, with each element
+corresponding to a single line of C<$filename>.
+
+The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
+assignment) contains breakpoints and actions. The keys are line numbers;
+you can set individual values, but not the whole hash. The Perl interpreter
+uses this hash to determine where breakpoints have been set. Any true value is
+considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
+Values are magical in numeric context: 1 if the line is breakable, 0 if not.
+
+The scalar C<${"_<$filename"}> simply contains the string C<_<$filename>.
+This is also the case for evaluated strings that contain subroutines, or
+which are currently being executed. The $filename for C<eval>ed strings looks
+like C<(eval 34)> or C<(re_eval 19)>.
+
+=head1 DEBUGGER STARTUP
+
+When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
+non-interactive sessions, C<.perldb> for interactive ones) that can set a number
+of options. In addition, this file may define a subroutine C<&afterinit>
+that will be executed (in the debugger's context) after the debugger has
+initialized itself.
+
+Next, it checks the C<PERLDB_OPTS> environment variable and treats its
+contents as the argument of a C<o> command in the debugger.
+
+=head2 STARTUP-ONLY OPTIONS
+
+The following options can only be specified at startup.
+To set them in your rcfile, add a call to
+C<&parse_options("optionName=new_value")>.
+
+=over 4
+
+=item * TTY
+
+the TTY to use for debugging i/o.
+
+=item * noTTY
+
+if set, goes in NonStop mode. On interrupt, if TTY is not set,
+uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using
+Term::Rendezvous. Current variant is to have the name of TTY in this
+file.
+
+=item * ReadLine
+
+if false, a dummy ReadLine is used, so you can debug
+ReadLine applications.
+
+=item * NonStop
+
+if true, no i/o is performed until interrupt.
+
+=item * LineInfo
+
+file or pipe to print line number info to. If it is a
+pipe, a short "emacs like" message is used.
+
+=item * RemotePort
+
+host:port to connect to on remote host for remote debugging.
+
+=item * HistFile
+
+file to store session history to. There is no default and so no
+history file is written unless this variable is explicitly set.
+
+=item * HistSize
+
+number of commands to store to the file specified in C<HistFile>.
+Default is 100.
+
+=back
+
+=head3 SAMPLE RCFILE
+
+ &parse_options("NonStop=1 LineInfo=db.out");
+ sub afterinit { $trace = 1; }
+
+The script will run without human intervention, putting trace
+information into C<db.out>. (If you interrupt it, you had better
+reset C<LineInfo> to something I<interactive>!)
+
+=head1 INTERNALS DESCRIPTION
+
+=head2 DEBUGGER INTERFACE VARIABLES
+
+Perl supplies the values for C<%sub>. It effectively inserts
+a C<&DB::DB();> in front of each place that can have a
+breakpoint. At each subroutine call, it calls C<&DB::sub> with
+C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
+{require 'perl5db.pl'}> before the first line.
+
+After each C<require>d file is compiled, but before it is executed, a
+call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
+is the expanded name of the C<require>d file (as found via C<%INC>).
+
+=head3 IMPORTANT INTERNAL VARIABLES
+
+=head4 C<$CreateTTY>
+
+Used to control when the debugger will attempt to acquire another TTY to be
+used for input.
+
+=over
+
+=item * 1 - on C<fork()>
+
+=item * 2 - debugger is started inside debugger
+
+=item * 4 - on startup
+
+=back
+
+=head4 C<$doret>
+
+The value -2 indicates that no return value should be printed.
+Any other positive value causes C<DB::sub> to print return values.
+
+=head4 C<$evalarg>
+
+The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
+contents of C<@_> when C<DB::eval> is called.
+
+=head4 C<$frame>
+
+Determines what messages (if any) will get printed when a subroutine (or eval)
+is entered or exited.
+
+=over 4
+
+=item * 0 - No enter/exit messages
+
+=item * 1 - Print I<entering> messages on subroutine entry
+
+=item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
+
+=item * 4 - Extended messages: C<< <in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line> >>. If no other flag is on, acts like 1+4.
+
+=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
+
+=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on.
+
+=back
+
+To get everything, use C<$frame=30> (or C<o f=30> as a debugger command).
+The debugger internally juggles the value of C<$frame> during execution to
+protect external modules that the debugger uses from getting traced.
+
+=head4 C<$level>
+
+Tracks current debugger nesting level. Used to figure out how many
+C<E<lt>E<gt>> pairs to surround the line number with when the debugger
+outputs a prompt. Also used to help determine if the program has finished
+during command parsing.
+
+=head4 C<$onetimeDump>
+
+Controls what (if anything) C<DB::eval()> will print after evaluating an
+expression.
+
+=over 4
+
+=item * C<undef> - don't print anything
+
+=item * C<dump> - use C<dumpvar.pl> to display the value returned
+
+=item * C<methods> - print the methods callable on the first item returned
+
+=back
+
+=head4 C<$onetimeDumpDepth>
+
+Controls how far down C<dumpvar.pl> will go before printing C<...> while
+dumping a structure. Numeric. If C<undef>, print all levels.
+
+=head4 C<$signal>
+
+Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
+which is called before every statement, checks this and puts the user into
+command mode if it finds C<$signal> set to a true value.
+
+=head4 C<$single>
+
+Controls behavior during single-stepping. Stacked in C<@stack> on entry to
+each subroutine; popped again at the end of each subroutine.
+
+=over 4
+
+=item * 0 - run continuously.
+
+=item * 1 - single-step, go into subs. The C<s> command.
+
+=item * 2 - single-step, don't go into subs. The C<n> command.
+
+=item * 4 - print current sub depth (turned on to force this when C<too much
+recursion> occurs.
+
+=back
+
+=head4 C<$trace>
+
+Controls the output of trace information.
+
+=over 4
+
+=item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
+
+=item * 2 - watch expressions are active
+
+=item * 4 - user defined a C<watchfunction()> in C<afterinit()>
+
+=back
+
+=head4 C<$slave_editor>
+
+1 if C<LINEINFO> was directed to a pipe; 0 otherwise.
+
+=head4 C<@cmdfhs>
+
+Stack of filehandles that C<DB::readline()> will read commands from.
+Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
+
+=head4 C<@dbline>
+
+Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
+supplied by the Perl interpreter to the debugger. Contains the source.
+
+=head4 C<@old_watch>
+
+Previous values of watch expressions. First set when the expression is
+entered; reset whenever the watch expression changes.
+
+=head4 C<@saved>
+
+Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
+so that the debugger can substitute safe values while it's running, and
+restore them when it returns control.
+
+=head4 C<@stack>
+
+Saves the current value of C<$single> on entry to a subroutine.
+Manipulated by the C<c> command to turn off tracing in all subs above the
+current one.
+
+=head4 C<@to_watch>
+
+The 'watch' expressions: to be evaluated before each line is executed.
+
+=head4 C<@typeahead>
+
+The typeahead buffer, used by C<DB::readline>.
+
+=head4 C<%alias>
+
+Command aliases. Stored as character strings to be substituted for a command
+entered.
+
+=head4 C<%break_on_load>
+
+Keys are file names, values are 1 (break when this file is loaded) or undef
+(don't break when it is loaded).
+
+=head4 C<%dbline>
+
+Keys are line numbers, values are C<condition\0action>. If used in numeric
+context, values are 0 if not breakable, 1 if breakable, no matter what is
+in the actual hash entry.
+
+=head4 C<%had_breakpoints>
+
+Keys are file names; values are bitfields:
+
+=over 4
+
+=item * 1 - file has a breakpoint in it.
+
+=item * 2 - file has an action in it.
+
+=back
+
+A zero or undefined value means this file has neither.
+
+=head4 C<%option>
+
+Stores the debugger options. These are character string values.
+
+=head4 C<%postponed>
+
+Saves breakpoints for code that hasn't been compiled yet.
+Keys are subroutine names, values are:
+
+=over 4
+
+=item * C<compile> - break when this sub is compiled
+
+=item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
+
+=back
+
+=head4 C<%postponed_file>
+
+This hash keeps track of breakpoints that need to be set for files that have
+not yet been compiled. Keys are filenames; values are references to hashes.
+Each of these hashes is keyed by line number, and its values are breakpoint
+definitions (C<condition\0action>).
+
+=head1 DEBUGGER INITIALIZATION
+
+The debugger's initialization actually jumps all over the place inside this
+package. This is because there are several BEGIN blocks (which of course
+execute immediately) spread through the code. Why is that?
+
+The debugger needs to be able to change some things and set some things up
+before the debugger code is compiled; most notably, the C<$deep> variable that
+C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
+debugger has to turn off warnings while the debugger code is compiled, but then
+restore them to their original setting before the program being debugged begins
+executing.
+
+The first C<BEGIN> block simply turns off warnings by saving the current
+setting of C<$^W> and then setting it to zero. The second one initializes
+the debugger variables that are needed before the debugger begins executing.
+The third one puts C<$^X> back to its former value.
+
+We'll detail the second C<BEGIN> block later; just remember that if you need
+to initialize something before the debugger starts really executing, that's
+where it has to go.
+
+=cut
+
+package DB;
+
+BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
+
+# Debugger for Perl 5.00x; perl5db.pl patch level:
+$VERSION = '1.33';
+
+$header = "perl5db.pl version $VERSION";
+
+=head1 DEBUGGER ROUTINES
+
+=head2 C<DB::eval()>
+
+This function replaces straight C<eval()> inside the debugger; it simplifies
+the process of evaluating code in the user's context.
+
+The code to be evaluated is passed via the package global variable
+C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
+
+Before we do the C<eval()>, we preserve the current settings of C<$trace>,
+C<$single>, C<$^D> and C<$usercontext>. The latter contains the
+preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the
+user's current package, grabbed when C<DB::DB> got control. This causes the
+proper context to be used when the eval is actually done. Afterward, we
+restore C<$trace>, C<$single>, and C<$^D>.
+
+Next we need to handle C<$@> without getting confused. We save C<$@> in a
+local lexical, localize C<$saved[0]> (which is where C<save()> will put
+C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
+C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
+considered sane by the debugger. If there was an C<eval()> error, we print
+it on the debugger's output. If C<$onetimedump> is defined, we call
+C<dumpit> if it's set to 'dump', or C<methods> if it's set to
+'methods'. Setting it to something else causes the debugger to do the eval
+but not print the result - handy if you want to do something else with it
+(the "watch expressions" code does this to get the value of the watch
+expression but not show it unless it matters).
+
+In any case, we then return the list of output from C<eval> to the caller,
+and unwinding restores the former version of C<$@> in C<@saved> as well
+(the localization of C<$saved[0]> goes away at the end of this scope).
+
+=head3 Parameters and variables influencing execution of DB::eval()
+
+C<DB::eval> isn't parameterized in the standard way; this is to keep the
+debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
+The variables listed below influence C<DB::eval()>'s execution directly.
+
+=over 4
+
+=item C<$evalarg> - the thing to actually be eval'ed
+
+=item C<$trace> - Current state of execution tracing
+
+=item C<$single> - Current state of single-stepping
+
+=item C<$onetimeDump> - what is to be displayed after the evaluation
+
+=item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
+
+=back
+
+The following variables are altered by C<DB::eval()> during its execution. They
+are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
+
+=over 4
+
+=item C<@res> - used to capture output from actual C<eval>.
+
+=item C<$otrace> - saved value of C<$trace>.
+
+=item C<$osingle> - saved value of C<$single>.
+
+=item C<$od> - saved value of C<$^D>.
+
+=item C<$saved[0]> - saved value of C<$@>.
+
+=item $\ - for output of C<$@> if there is an evaluation error.
+
+=back
+
+=head3 The problem of lexicals
+
+The context of C<DB::eval()> presents us with some problems. Obviously,
+we want to be 'sandboxed' away from the debugger's internals when we do
+the eval, but we need some way to control how punctuation variables and
+debugger globals are used.
+
+We can't use local, because the code inside C<DB::eval> can see localized
+variables; and we can't use C<my> either for the same reason. The code
+in this routine compromises and uses C<my>.
+
+After this routine is over, we don't have user code executing in the debugger's
+context, so we can use C<my> freely.
+
+=cut
+
+############################################## Begin lexical danger zone
+
+# 'my' variables used here could leak into (that is, be visible in)
+# the context that the code being evaluated is executing in. This means that
+# the code could modify the debugger's variables.
+#
+# Fiddling with the debugger's context could be Bad. We insulate things as
+# much as we can.
+
+sub eval {
+
+ # 'my' would make it visible from user code
+ # but so does local! --tchrist
+ # Remember: this localizes @DB::res, not @main::res.
+ local @res;
+ {
+
+ # Try to keep the user code from messing with us. Save these so that
+ # even if the eval'ed code changes them, we can put them back again.
+ # Needed because the user could refer directly to the debugger's
+ # package globals (and any 'my' variables in this containing scope)
+ # inside the eval(), and we want to try to stay safe.
+ local $otrace = $trace;
+ local $osingle = $single;
+ local $od = $^D;
+
+ # Untaint the incoming eval() argument.
+ { ($evalarg) = $evalarg =~ /(.*)/s; }
+
+ # $usercontext built in DB::DB near the comment
+ # "set up the context for DB::eval ..."
+ # Evaluate and save any results.
+ @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
+
+ # Restore those old values.
+ $trace = $otrace;
+ $single = $osingle;
+ $^D = $od;
+ }
+
+ # Save the current value of $@, and preserve it in the debugger's copy
+ # of the saved precious globals.
+ my $at = $@;
+
+ # Since we're only saving $@, we only have to localize the array element
+ # that it will be stored in.
+ local $saved[0]; # Preserve the old value of $@
+ eval { &DB::save };
+
+ # Now see whether we need to report an error back to the user.
+ if ($at) {
+ local $\ = '';
+ print $OUT $at;
+ }
+
+ # Display as required by the caller. $onetimeDump and $onetimedumpDepth
+ # are package globals.
+ elsif ($onetimeDump) {
+ if ( $onetimeDump eq 'dump' ) {
+ local $option{dumpDepth} = $onetimedumpDepth
+ if defined $onetimedumpDepth;
+ dumpit( $OUT, \@res );
+ }
+ elsif ( $onetimeDump eq 'methods' ) {
+ methods( $res[0] );
+ }
+ } ## end elsif ($onetimeDump)
+ @res;
+} ## end sub eval
+
+############################################## End lexical danger zone
+
+# After this point it is safe to introduce lexicals.
+# The code being debugged will be executing in its own context, and
+# can't see the inside of the debugger.
+#
+# However, one should not overdo it: leave as much control from outside as
+# possible. If you make something a lexical, it's not going to be addressable
+# from outside the debugger even if you know its name.
+
+# This file is automatically included if you do perl -d.
+# It's probably not useful to include this yourself.
+#
+# Before venturing further into these twisty passages, it is
+# wise to read the perldebguts man page or risk the ire of dragons.
+#
+# (It should be noted that perldebguts will tell you a lot about
+# the underlying mechanics of how the debugger interfaces into the
+# Perl interpreter, but not a lot about the debugger itself. The new
+# comments in this code try to address this problem.)
+
+# Note that no subroutine call is possible until &DB::sub is defined
+# (for subroutines defined outside of the package DB). In fact the same is
+# true if $deep is not defined.
+
+# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
+
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+
+# (We have made efforts to clarify the comments in the change log
+# in other places; some of them may seem somewhat obscure as they
+# were originally written, and explaining them away from the code
+# in question seems conterproductive.. -JM)
+
+########################################################################
+# Changes: 0.94
+# + A lot of things changed after 0.94. First of all, core now informs
+# debugger about entry into XSUBs, overloaded operators, tied operations,
+# BEGIN and END. Handy with `O f=2'.
+# + This can make debugger a little bit too verbose, please be patient
+# and report your problems promptly.
+# + Now the option frame has 3 values: 0,1,2. XXX Document!
+# + Note that if DESTROY returns a reference to the object (or object),
+# the deletion of data may be postponed until the next function call,
+# due to the need to examine the return value.
+#
+# Changes: 0.95
+# + `v' command shows versions.
+#
+# Changes: 0.96
+# + `v' command shows version of readline.
+# primitive completion works (dynamic variables, subs for `b' and `l',
+# options). Can `p %var'
+# + Better help (`h <' now works). New commands <<, >>, {, {{.
+# {dump|print}_trace() coded (to be able to do it from <<cmd).
+# + `c sub' documented.
+# + At last enough magic combined to stop after the end of debuggee.
+# + !! should work now (thanks to Emacs bracket matching an extra
+# `]' in a regexp is caught).
+# + `L', `D' and `A' span files now (as documented).
+# + Breakpoints in `require'd code are possible (used in `R').
+# + Some additional words on internal work of debugger.
+# + `b load filename' implemented.
+# + `b postpone subr' implemented.
+# + now only `q' exits debugger (overwritable on $inhibit_exit).
+# + When restarting debugger breakpoints/actions persist.
+# + Buglet: When restarting debugger only one breakpoint/action per
+# autoloaded function persists.
+#
+# Changes: 0.97: NonStop will not stop in at_exit().
+# + Option AutoTrace implemented.
+# + Trace printed differently if frames are printed too.
+# + new `inhibitExit' option.
+# + printing of a very long statement interruptible.
+# Changes: 0.98: New command `m' for printing possible methods
+# + 'l -' is a synonym for `-'.
+# + Cosmetic bugs in printing stack trace.
+# + `frame' & 8 to print "expanded args" in stack trace.
+# + Can list/break in imported subs.
+# + new `maxTraceLen' option.
+# + frame & 4 and frame & 8 granted.
+# + new command `m'
+# + nonstoppable lines do not have `:' near the line number.
+# + `b compile subname' implemented.
+# + Will not use $` any more.
+# + `-' behaves sane now.
+# Changes: 0.99: Completion for `f', `m'.
+# + `m' will remove duplicate names instead of duplicate functions.
+# + `b load' strips trailing whitespace.
+# completion ignores leading `|'; takes into account current package
+# when completing a subroutine name (same for `l').
+# Changes: 1.07: Many fixed by tchrist 13-March-2000
+# BUG FIXES:
+# + Added bare minimal security checks on perldb rc files, plus
+# comments on what else is needed.
+# + Fixed the ornaments that made "|h" completely unusable.
+# They are not used in print_help if they will hurt. Strip pod
+# if we're paging to less.
+# + Fixed mis-formatting of help messages caused by ornaments
+# to restore Larry's original formatting.
+# + Fixed many other formatting errors. The code is still suboptimal,
+# and needs a lot of work at restructuring. It's also misindented
+# in many places.
+# + Fixed bug where trying to look at an option like your pager
+# shows "1".
+# + Fixed some $? processing. Note: if you use csh or tcsh, you will
+# lose. You should consider shell escapes not using their shell,
+# or else not caring about detailed status. This should really be
+# unified into one place, too.
+# + Fixed bug where invisible trailing whitespace on commands hoses you,
+# tricking Perl into thinking you weren't calling a debugger command!
+# + Fixed bug where leading whitespace on commands hoses you. (One
+# suggests a leading semicolon or any other irrelevant non-whitespace
+# to indicate literal Perl code.)
+# + Fixed bugs that ate warnings due to wrong selected handle.
+# + Fixed a precedence bug on signal stuff.
+# + Fixed some unseemly wording.
+# + Fixed bug in help command trying to call perl method code.
+# + Fixed to call dumpvar from exception handler. SIGPIPE killed us.
+# ENHANCEMENTS:
+# + Added some comments. This code is still nasty spaghetti.
+# + Added message if you clear your pre/post command stacks which was
+# very easy to do if you just typed a bare >, <, or {. (A command
+# without an argument should *never* be a destructive action; this
+# API is fundamentally screwed up; likewise option setting, which
+# is equally buggered.)
+# + Added command stack dump on argument of "?" for >, <, or {.
+# + Added a semi-built-in doc viewer command that calls man with the
+# proper %Config::Config path (and thus gets caching, man -k, etc),
+# or else perldoc on obstreperous platforms.
+# + Added to and rearranged the help information.
+# + Detected apparent misuse of { ... } to declare a block; this used
+# to work but now is a command, and mysteriously gave no complaint.
+#
+# Changes: 1.08: Apr 25, 2001 Jon Eveland <jweveland@yahoo.com>
+# BUG FIX:
+# + This patch to perl5db.pl cleans up formatting issues on the help
+# summary (h h) screen in the debugger. Mostly columnar alignment
+# issues, plus converted the printed text to use all spaces, since
+# tabs don't seem to help much here.
+#
+# Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
+# Minor bugs corrected;
+# + Support for auto-creation of new TTY window on startup, either
+# unconditionally, or if started as a kid of another debugger session;
+# + New `O'ption CreateTTY
+# I<CreateTTY> bits control attempts to create a new TTY on events:
+# 1: on fork()
+# 2: debugger is started inside debugger
+# 4: on startup
+# + Code to auto-create a new TTY window on OS/2 (currently one
+# extra window per session - need named pipes to have more...);
+# + Simplified interface for custom createTTY functions (with a backward
+# compatibility hack); now returns the TTY name to use; return of ''
+# means that the function reset the I/O handles itself;
+# + Better message on the semantic of custom createTTY function;
+# + Convert the existing code to create a TTY into a custom createTTY
+# function;
+# + Consistent support for TTY names of the form "TTYin,TTYout";
+# + Switch line-tracing output too to the created TTY window;
+# + make `b fork' DWIM with CORE::GLOBAL::fork;
+# + High-level debugger API cmd_*():
+# cmd_b_load($filenamepart) # b load filenamepart
+# cmd_b_line($lineno [, $cond]) # b lineno [cond]
+# cmd_b_sub($sub [, $cond]) # b sub [cond]
+# cmd_stop() # Control-C
+# cmd_d($lineno) # d lineno (B)
+# The cmd_*() API returns FALSE on failure; in this case it outputs
+# the error message to the debugging output.
+# + Low-level debugger API
+# break_on_load($filename) # b load filename
+# @files = report_break_on_load() # List files with load-breakpoints
+# breakable_line_in_filename($name, $from [, $to])
+# # First breakable line in the
+# # range $from .. $to. $to defaults
+# # to $from, and may be less than
+# # $to
+# breakable_line($from [, $to]) # Same for the current file
+# break_on_filename_line($name, $lineno [, $cond])
+# # Set breakpoint,$cond defaults to
+# # 1
+# break_on_filename_line_range($name, $from, $to [, $cond])
+# # As above, on the first
+# # breakable line in range
+# break_on_line($lineno [, $cond]) # As above, in the current file
+# break_subroutine($sub [, $cond]) # break on the first breakable line
+# ($name, $from, $to) = subroutine_filename_lines($sub)
+# # The range of lines of the text
+# The low-level API returns TRUE on success, and die()s on failure.
+#
+# Changes: 1.10: May 23, 2001 Daniel Lewart <d-lewart@uiuc.edu>
+# BUG FIXES:
+# + Fixed warnings generated by "perl -dWe 42"
+# + Corrected spelling errors
+# + Squeezed Help (h) output into 80 columns
+#
+# Changes: 1.11: May 24, 2001 David Dyck <dcd@tc.fluke.com>
+# + Made "x @INC" work like it used to
+#
+# Changes: 1.12: May 24, 2001 Daniel Lewart <d-lewart@uiuc.edu>
+# + Fixed warnings generated by "O" (Show debugger options)
+# + Fixed warnings generated by "p 42" (Print expression)
+# Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com
+# + Added windowSize option
+# Changes: 1.14: Oct 9, 2001 multiple
+# + Clean up after itself on VMS (Charles Lane in 12385)
+# + Adding "@ file" syntax (Peter Scott in 12014)
+# + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457)
+# + $^S and other debugger fixes (Ilya Zakharevich in 11120)
+# + Forgot a my() declaration (Ilya Zakharevich in 11085)
+# Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com>
+# + Updated 1.14 change log
+# + Added *dbline explainatory comments
+# + Mentioning perldebguts man page
+# Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
+# + $onetimeDump improvements
+# Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
+# Moved some code to cmd_[.]()'s for clarity and ease of handling,
+# rationalised the following commands and added cmd_wrapper() to
+# enable switching between old and frighteningly consistent new
+# behaviours for diehards: 'o CommandSet=pre580' (sigh...)
+# a(add), A(del) # action expr (added del by line)
+# + b(add), B(del) # break [line] (was b,D)
+# + w(add), W(del) # watch expr (was W,W)
+# # added del by expr
+# + h(summary), h h(long) # help (hh) (was h h,h)
+# + m(methods), M(modules) # ... (was m,v)
+# + o(option) # lc (was O)
+# + v(view code), V(view Variables) # ... (was w,V)
+# Changes: 1.18: Mar 17, 2002 Richard Foley <richard.foley@rfi.net>
+# + fixed missing cmd_O bug
+# Changes: 1.19: Mar 29, 2002 Spider Boardman
+# + Added missing local()s -- DB::DB is called recursively.
+# Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley@rfi.net>
+# + pre'n'post commands no longer trashed with no args
+# + watch val joined out of eval()
+# Changes: 1.21: Jun 04, 2003 Joe McMahon <mcmahon@ibiblio.org>
+# + Added comments and reformatted source. No bug fixes/enhancements.
+# + Includes cleanup by Robin Barker and Jarkko Hietaniemi.
+# Changes: 1.22 Jun 09, 2003 Alex Vandiver <alexmv@MIT.EDU>
+# + Flush stdout/stderr before the debugger prompt is printed.
+# Changes: 1.23: Dec 21, 2003 Dominique Quatravaux
+# + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
+# Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley@rfi.net>
+# + Added command to save all debugger commands for sourcing later.
+# + Added command to display parent inheritance tree of given class.
+# + Fixed minor newline in history bug.
+# Changes: 1.25: Apr 17, 2004 Richard Foley <richard.foley@rfi.net>
+# + Fixed option bug (setting invalid options + not recognising valid short forms)
+# Changes: 1.26: Apr 22, 2004 Richard Foley <richard.foley@rfi.net>
+# + unfork the 5.8.x and 5.9.x debuggers.
+# + whitespace and assertions call cleanup across versions
+# + H * deletes (resets) history
+# + i now handles Class + blessed objects
+# Changes: 1.27: May 09, 2004 Richard Foley <richard.foley@rfi.net>
+# + updated pod page references - clunky.
+# + removed windowid restriction for forking into an xterm.
+# + more whitespace again.
+# + wrapped restart and enabled rerun [-n] (go back n steps) command.
+# Changes: 1.28: Oct 12, 2004 Richard Foley <richard.foley@rfi.net>
+# + Added threads support (inc. e and E commands)
+# Changes: 1.29: Nov 28, 2006 Bo Lindbergh <blgl@hagernas.com>
+# + Added macosx_get_fork_TTY support
+# Changes: 1.30: Mar 06, 2007 Andreas Koenig <andk@cpan.org>
+# + Added HistFile, HistSize
+# Changes: 1.31
+# + Remove support for assertions and -A
+# + stop NEXT::AUTOLOAD from emitting warnings under the debugger. RT #25053
+# + "update for Mac OS X 10.5" [finding the tty device]
+# + "What I needed to get the forked debugger to work" [on VMS]
+# + [perl #57016] debugger: o warn=0 die=0 ignored
+# + Note, but don't use, PERLDBf_SAVESRC
+# + Fix #7013: lvalue subs not working inside debugger
+# Changes: 1.32: Jun 03, 2009 Jonathan Leto <jonathan@leto.net>
+# + Fix bug where a key _< with undefined value was put into the symbol table
+# + when the $filename variable is not set
+########################################################################
+
+=head1 DEBUGGER INITIALIZATION
+
+The debugger starts up in phases.
+
+=head2 BASIC SETUP
+
+First, it initializes the environment it wants to run in: turning off
+warnings during its own compilation, defining variables which it will need
+to avoid warnings later, setting itself up to not exit when the program
+terminates, and defaulting to printing return values for the C<r> command.
+
+=cut
+
+# Needed for the statement after exec():
+#
+# This BEGIN block is simply used to switch off warnings during debugger
+# compiliation. Probably it would be better practice to fix the warnings,
+# but this is how it's done at the moment.
+
+BEGIN {
+ $ini_warn = $^W;
+ $^W = 0;
+} # Switch compilation warnings off until another BEGIN.
+
+local ($^W) = 0; # Switch run-time warnings off during init.
+
+=head2 THREADS SUPPORT
+
+If we are running under a threaded Perl, we require threads and threads::shared
+if the environment variable C<PERL5DB_THREADED> is set, to enable proper
+threaded debugger control. C<-dt> can also be used to set this.
+
+Each new thread will be announced and the debugger prompt will always inform
+you of each new thread created. It will also indicate the thread id in which
+we are currently running within the prompt like this:
+
+ [tid] DB<$i>
+
+Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
+command prompt. The prompt will show: C<[0]> when running under threads, but
+not actually in a thread. C<[tid]> is consistent with C<gdb> usage.
+
+While running under threads, when you set or delete a breakpoint (etc.), this
+will apply to all threads, not just the currently running one. When you are
+in a currently executing thread, you will stay there until it completes. With
+the current implementation it is not currently possible to hop from one thread
+to another.
+
+The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.
+
+Note that threading support was built into the debugger as of Perl version
+C<5.8.6> and debugger version C<1.2.8>.
+
+=cut
+
+BEGIN {
+ # ensure we can share our non-threaded variables or no-op
+ if ($ENV{PERL5DB_THREADED}) {
+ require threads;
+ require threads::shared;
+ import threads::shared qw(share);
+ $DBGR;
+ share(\$DBGR);
+ lock($DBGR);
+ print "Threads support enabled\n";
+ } else {
+ *lock = sub(*) {};
+ *share = sub(*) {};
+ }
+}
+
+# This would probably be better done with "use vars", but that wasn't around
+# when this code was originally written. (Neither was "use strict".) And on
+# the principle of not fiddling with something that was working, this was
+# left alone.
+warn( # Do not ;-)
+ # These variables control the execution of 'dumpvar.pl'.
+ $dumpvar::hashDepth,
+ $dumpvar::arrayDepth,
+ $dumpvar::dumpDBFiles,
+ $dumpvar::dumpPackages,
+ $dumpvar::quoteHighBit,
+ $dumpvar::printUndef,
+ $dumpvar::globPrint,
+ $dumpvar::usageOnly,
+
+ # used to save @ARGV and extract any debugger-related flags.
+ @ARGS,
+
+ # used to control die() reporting in diesignal()
+ $Carp::CarpLevel,
+
+ # used to prevent multiple entries to diesignal()
+ # (if for instance diesignal() itself dies)
+ $panic,
+
+ # used to prevent the debugger from running nonstop
+ # after a restart
+ $second_time,
+ )
+ if 0;
+
+# without threads, $filename is not defined until DB::DB is called
+foreach my $k (keys (%INC)) {
+ &share(\$main::{'_<'.$filename}) if defined $filename;
+};
+
+# Command-line + PERLLIB:
+# Save the contents of @INC before they are modified elsewhere.
+@ini_INC = @INC;
+
+# This was an attempt to clear out the previous values of various
+# trapped errors. Apparently it didn't help. XXX More info needed!
+# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
+
+# We set these variables to safe values. We don't want to blindly turn
+# off warnings, because other packages may still want them.
+$trace = $signal = $single = 0; # Uninitialized warning suppression
+ # (local $^W cannot help - other packages!).
+
+# Default to not exiting when program finishes; print the return
+# value when the 'r' command is used to return from a subroutine.
+$inhibit_exit = $option{PrintRet} = 1;
+
+=head1 OPTION PROCESSING
+
+The debugger's options are actually spread out over the debugger itself and
+C<dumpvar.pl>; some of these are variables to be set, while others are
+subs to be called with a value. To try to make this a little easier to
+manage, the debugger uses a few data structures to define what options
+are legal and how they are to be processed.
+
+First, the C<@options> array defines the I<names> of all the options that
+are to be accepted.
+
+=cut
+
+@options = qw(
+ CommandSet HistFile HistSize
+ hashDepth arrayDepth dumpDepth
+ DumpDBFiles DumpPackages DumpReused
+ compactDump veryCompact quote
+ HighBit undefPrint globPrint
+ PrintRet UsageOnly frame
+ AutoTrace TTY noTTY
+ ReadLine NonStop LineInfo
+ maxTraceLen recallCommand ShellBang
+ pager tkRunning ornaments
+ signalLevel warnLevel dieLevel
+ inhibit_exit ImmediateStop bareStringify
+ CreateTTY RemotePort windowSize
+ DollarCaretP
+);
+
+@RememberOnROptions = qw(DollarCaretP);
+
+=pod
+
+Second, C<optionVars> lists the variables that each option uses to save its
+state.
+
+=cut
+
+%optionVars = (
+ hashDepth => \$dumpvar::hashDepth,
+ arrayDepth => \$dumpvar::arrayDepth,
+ CommandSet => \$CommandSet,
+ DumpDBFiles => \$dumpvar::dumpDBFiles,
+ DumpPackages => \$dumpvar::dumpPackages,
+ DumpReused => \$dumpvar::dumpReused,
+ HighBit => \$dumpvar::quoteHighBit,
+ undefPrint => \$dumpvar::printUndef,
+ globPrint => \$dumpvar::globPrint,
+ UsageOnly => \$dumpvar::usageOnly,
+ CreateTTY => \$CreateTTY,
+ bareStringify => \$dumpvar::bareStringify,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
+ ImmediateStop => \$ImmediateStop,
+ RemotePort => \$remoteport,
+ windowSize => \$window,
+ HistFile => \$histfile,
+ HistSize => \$histsize,
+);
+
+=pod
+
+Third, C<%optionAction> defines the subroutine to be called to process each
+option.
+
+=cut
+
+%optionAction = (
+ compactDump => \&dumpvar::compactDump,
+ veryCompact => \&dumpvar::veryCompact,
+ quote => \&dumpvar::quote,
+ TTY => \&TTY,
+ noTTY => \&noTTY,
+ ReadLine => \&ReadLine,
+ NonStop => \&NonStop,
+ LineInfo => \&LineInfo,
+ recallCommand => \&recallCommand,
+ ShellBang => \&shellBang,
+ pager => \&pager,
+ signalLevel => \&signalLevel,
+ warnLevel => \&warnLevel,
+ dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
+ RemotePort => \&RemotePort,
+ DollarCaretP => \&DollarCaretP,
+);
+
+=pod
+
+Last, the C<%optionRequire> notes modules that must be C<require>d if an
+option is used.
+
+=cut
+
+# Note that this list is not complete: several options not listed here
+# actually require that dumpvar.pl be loaded for them to work, but are
+# not in the table. A subsequent patch will correct this problem; for
+# the moment, we're just recommenting, and we are NOT going to change
+# function.
+%optionRequire = (
+ compactDump => 'dumpvar.pl',
+ veryCompact => 'dumpvar.pl',
+ quote => 'dumpvar.pl',
+);
+
+=pod
+
+There are a number of initialization-related variables which can be set
+by putting code to set them in a BEGIN block in the C<PERL5DB> environment
+variable. These are:
+
+=over 4
+
+=item C<$rl> - readline control XXX needs more explanation
+
+=item C<$warnLevel> - whether or not debugger takes over warning handling
+
+=item C<$dieLevel> - whether or not debugger takes over die handling
+
+=item C<$signalLevel> - whether or not debugger takes over signal handling
+
+=item C<$pre> - preprompt actions (array reference)
+
+=item C<$post> - postprompt actions (array reference)
+
+=item C<$pretype>
+
+=item C<$CreateTTY> - whether or not to create a new TTY for this debugger
+
+=item C<$CommandSet> - which command set to use (defaults to new, documented set)
+
+=back
+
+=cut
+
+# These guys may be defined in $ENV{PERL5DB} :
+$rl = 1 unless defined $rl;
+$warnLevel = 1 unless defined $warnLevel;
+$dieLevel = 1 unless defined $dieLevel;
+$signalLevel = 1 unless defined $signalLevel;
+$pre = [] unless defined $pre;
+$post = [] unless defined $post;
+$pretype = [] unless defined $pretype;
+$CreateTTY = 3 unless defined $CreateTTY;
+$CommandSet = '580' unless defined $CommandSet;
+
+share($rl);
+share($warnLevel);
+share($dieLevel);
+share($signalLevel);
+share($pre);
+share($post);
+share($pretype);
+share($rl);
+share($CreateTTY);
+share($CommandSet);
+
+=pod
+
+The default C<die>, C<warn>, and C<signal> handlers are set up.
+
+=cut
+
+warnLevel($warnLevel);
+dieLevel($dieLevel);
+signalLevel($signalLevel);
+
+=pod
+
+The pager to be used is needed next. We try to get it from the
+environment first. If it's not defined there, we try to find it in
+the Perl C<Config.pm>. If it's not there, we default to C<more>. We
+then call the C<pager()> function to save the pager name.
+
+=cut
+
+# This routine makes sure $pager is set up so that '|' can use it.
+pager(
+
+ # If PAGER is defined in the environment, use it.
+ defined $ENV{PAGER}
+ ? $ENV{PAGER}
+
+ # If not, see if Config.pm defines it.
+ : eval { require Config }
+ && defined $Config::Config{pager}
+ ? $Config::Config{pager}
+
+ # If not, fall back to 'more'.
+ : 'more'
+ )
+ unless defined $pager;
+
+=pod
+
+We set up the command to be used to access the man pages, the command
+recall character (C<!> unless otherwise defined) and the shell escape
+character (C<!> unless otherwise defined). Yes, these do conflict, and
+neither works in the debugger at the moment.
+
+=cut
+
+setman();
+
+# Set up defaults for command recall and shell escape (note:
+# these currently don't work in linemode debugging).
+&recallCommand("!") unless defined $prc;
+&shellBang("!") unless defined $psh;
+
+=pod
+
+We then set up the gigantic string containing the debugger help.
+We also set the limit on the number of arguments we'll display during a
+trace.
+
+=cut
+
+sethelp();
+
+# If we didn't get a default for the length of eval/stack trace args,
+# set it here.
+$maxtrace = 400 unless defined $maxtrace;
+
+=head2 SETTING UP THE DEBUGGER GREETING
+
+The debugger I<greeting> helps to inform the user how many debuggers are
+running, and whether the current debugger is the primary or a child.
+
+If we are the primary, we just hang onto our pid so we'll have it when
+or if we start a child debugger. If we are a child, we'll set things up
+so we'll have a unique greeting and so the parent will give us our own
+TTY later.
+
+We save the current contents of the C<PERLDB_PIDS> environment variable
+because we mess around with it. We'll also need to hang onto it because
+we'll need it if we restart.
+
+Child debuggers make a label out of the current PID structure recorded in
+PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
+yet so the parent will give them one later via C<resetterm()>.
+
+=cut
+
+# Save the current contents of the environment; we're about to
+# much with it. We'll need this if we have to restart.
+$ini_pids = $ENV{PERLDB_PIDS};
+
+if ( defined $ENV{PERLDB_PIDS} ) {
+
+ # We're a child. Make us a label out of the current PID structure
+ # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
+ # a term yet so the parent will give us one later via resetterm().
+
+ my $env_pids = $ENV{PERLDB_PIDS};
+ $pids = "[$env_pids]";
+
+ # Unless we are on OpenVMS, all programs under the DCL shell run under
+ # the same PID.
+
+ if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
+ $term_pid = $$;
+ }
+ else {
+ $ENV{PERLDB_PIDS} .= "->$$";
+ $term_pid = -1;
+ }
+
+} ## end if (defined $ENV{PERLDB_PIDS...
+else {
+
+ # We're the parent PID. Initialize PERLDB_PID in case we end up with a
+ # child debugger, and mark us as the parent, so we'll know to set up
+ # more TTY's is we have to.
+ $ENV{PERLDB_PIDS} = "$$";
+ $pids = "[pid=$$]";
+ $term_pid = $$;
+}
+
+$pidprompt = '';
+
+# Sets up $emacs as a synonym for $slave_editor.
+*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
+
+=head2 READING THE RC FILE
+
+The debugger will read a file of initialization options if supplied. If
+running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
+
+=cut
+
+# As noted, this test really doesn't check accurately that the debugger
+# is running at a terminal or not.
+
+my $dev_tty = '/dev/tty';
+ $dev_tty = 'TT:' if ($^O eq 'VMS');
+if ( -e $dev_tty ) { # this is the wrong metric!
+ $rcfile = ".perldb";
+}
+else {
+ $rcfile = "perldb.ini";
+}
+
+=pod
+
+The debugger does a safety test of the file to be read. It must be owned
+either by the current user or root, and must only be writable by the owner.
+
+=cut
+
+# This wraps a safety test around "do" to read and evaluate the init file.
+#
+# This isn't really safe, because there's a race
+# between checking and opening. The solution is to
+# open and fstat the handle, but then you have to read and
+# eval the contents. But then the silly thing gets
+# your lexical scope, which is unfortunate at best.
+sub safe_do {
+ my $file = shift;
+
+ # Just exactly what part of the word "CORE::" don't you understand?
+ local $SIG{__WARN__};
+ local $SIG{__DIE__};
+
+ unless ( is_safe_file($file) ) {
+ CORE::warn <<EO_GRIPE;
+perldb: Must not source insecure rcfile $file.
+ You or the superuser must be the owner, and it must not
+ be writable by anyone but its owner.
+EO_GRIPE
+ return;
+ } ## end unless (is_safe_file($file...
+
+ do $file;
+ CORE::warn("perldb: couldn't parse $file: $@") if $@;
+} ## end sub safe_do
+
+# This is the safety test itself.
+#
+# Verifies that owner is either real user or superuser and that no
+# one but owner may write to it. This function is of limited use
+# when called on a path instead of upon a handle, because there are
+# no guarantees that filename (by dirent) whose file (by ino) is
+# eventually accessed is the same as the one tested.
+# Assumes that the file's existence is not in doubt.
+sub is_safe_file {
+ my $path = shift;
+ stat($path) || return; # mysteriously vaporized
+ my ( $dev, $ino, $mode, $nlink, $uid, $gid ) = stat(_);
+
+ return 0 if $uid != 0 && $uid != $<;
+ return 0 if $mode & 022;
+ return 1;
+} ## end sub is_safe_file
+
+# If the rcfile (whichever one we decided was the right one to read)
+# exists, we safely do it.
+if ( -f $rcfile ) {
+ safe_do("./$rcfile");
+}
+
+# If there isn't one here, try the user's home directory.
+elsif ( defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile" ) {
+ safe_do("$ENV{HOME}/$rcfile");
+}
+
+# Else try the login directory.
+elsif ( defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile" ) {
+ safe_do("$ENV{LOGDIR}/$rcfile");
+}
+
+# If the PERLDB_OPTS variable has options in it, parse those out next.
+if ( defined $ENV{PERLDB_OPTS} ) {
+ parse_options( $ENV{PERLDB_OPTS} );
+}
+
+=pod
+
+The last thing we do during initialization is determine which subroutine is
+to be used to obtain a new terminal when a new debugger is started. Right now,
+the debugger only handles X Windows, OS/2, and Mac OS X (darwin).
+
+=cut
+
+# Set up the get_fork_TTY subroutine to be aliased to the proper routine.
+# Works if you're running an xterm or xterm-like window, or you're on
+# OS/2, or on Mac OS X. This may need some expansion.
+
+if (not defined &get_fork_TTY) # only if no routine exists
+{
+ if (defined $ENV{TERM} # If we know what kind
+ # of terminal this is,
+ and $ENV{TERM} eq 'xterm' # and it's an xterm,
+ and defined $ENV{DISPLAY} # and what display it's on,
+ )
+ {
+ *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
+ }
+ elsif ( $^O eq 'os2' ) { # If this is OS/2,
+ *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
+ }
+ elsif ( $^O eq 'darwin' # If this is Mac OS X
+ and defined $ENV{TERM_PROGRAM} # and we're running inside
+ and $ENV{TERM_PROGRAM}
+ eq 'Apple_Terminal' # Terminal.app
+ )
+ {
+ *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version
+ }
+} ## end if (not defined &get_fork_TTY...
+
+# untaint $^O, which may have been tainted by the last statement.
+# see bug [perl #24674]
+$^O =~ m/^(.*)\z/;
+$^O = $1;
+
+# Here begin the unreadable code. It needs fixing.
+
+=head2 RESTART PROCESSING
+
+This section handles the restart command. When the C<R> command is invoked, it
+tries to capture all of the state it can into environment variables, and
+then sets C<PERLDB_RESTART>. When we start executing again, we check to see
+if C<PERLDB_RESTART> is there; if so, we reload all the information that
+the R command stuffed into the environment variables.
+
+ PERLDB_RESTART - flag only, contains no restart data itself.
+ PERLDB_HIST - command history, if it's available
+ PERLDB_ON_LOAD - breakpoints set by the rc file
+ PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions
+ PERLDB_VISITED - files that had breakpoints
+ PERLDB_FILE_... - breakpoints for a file
+ PERLDB_OPT - active options
+ PERLDB_INC - the original @INC
+ PERLDB_PRETYPE - preprompt debugger actions
+ PERLDB_PRE - preprompt Perl code
+ PERLDB_POST - post-prompt Perl code
+ PERLDB_TYPEAHEAD - typeahead captured by readline()
+
+We chug through all these variables and plug the values saved in them
+back into the appropriate spots in the debugger.
+
+=cut
+
+if ( exists $ENV{PERLDB_RESTART} ) {
+
+ # We're restarting, so we don't need the flag that says to restart anymore.
+ delete $ENV{PERLDB_RESTART};
+
+ # $restart = 1;
+ @hist = get_list('PERLDB_HIST');
+ %break_on_load = get_list("PERLDB_ON_LOAD");
+ %postponed = get_list("PERLDB_POSTPONE");
+
+ share(@hist);
+ share(@truehist);
+ share(%break_on_load);
+ share(%postponed);
+
+ # restore breakpoints/actions
+ my @had_breakpoints = get_list("PERLDB_VISITED");
+ for ( 0 .. $#had_breakpoints ) {
+ my %pf = get_list("PERLDB_FILE_$_");
+ $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf;
+ }
+
+ # restore options
+ my %opt = get_list("PERLDB_OPT");
+ my ( $opt, $val );
+ while ( ( $opt, $val ) = each %opt ) {
+ $val =~ s/[\\\']/\\$1/g;
+ parse_options("$opt'$val'");
+ }
+
+ # restore original @INC
+ @INC = get_list("PERLDB_INC");
+ @ini_INC = @INC;
+
+ # return pre/postprompt actions and typeahead buffer
+ $pretype = [ get_list("PERLDB_PRETYPE") ];
+ $pre = [ get_list("PERLDB_PRE") ];
+ $post = [ get_list("PERLDB_POST") ];
+ @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
+} ## end if (exists $ENV{PERLDB_RESTART...
+
+=head2 SETTING UP THE TERMINAL
+
+Now, we'll decide how the debugger is going to interact with the user.
+If there's no TTY, we set the debugger to run non-stop; there's not going
+to be anyone there to enter commands.
+
+=cut
+
+if ($notty) {
+ $runnonstop = 1;
+ share($runnonstop);
+}
+
+=pod
+
+If there is a TTY, we have to determine who it belongs to before we can
+proceed. If this is a slave editor or graphical debugger (denoted by
+the first command-line switch being '-emacs'), we shift this off and
+set C<$rl> to 0 (XXX ostensibly to do straight reads).
+
+=cut
+
+else {
+
+ # Is Perl being run from a slave editor or graphical debugger?
+ # If so, don't use readline, and set $slave_editor = 1.
+ $slave_editor =
+ ( ( defined $main::ARGV[0] ) and ( $main::ARGV[0] eq '-emacs' ) );
+ $rl = 0, shift(@main::ARGV) if $slave_editor;
+
+ #require Term::ReadLine;
+
+=pod
+
+We then determine what the console should be on various systems:
+
+=over 4
+
+=item * Cygwin - We use C<stdin> instead of a separate device.
+
+=cut
+
+ if ( $^O eq 'cygwin' ) {
+
+ # /dev/tty is binary. use stdin for textmode
+ undef $console;
+ }
+
+=item * Unix - use C</dev/tty>.
+
+=cut
+
+ elsif ( -e "/dev/tty" ) {
+ $console = "/dev/tty";
+ }
+
+=item * Windows or MSDOS - use C<con>.
+
+=cut
+
+ elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
+ $console = "con";
+ }
+
+=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev:
+Console> if not.
+
+Note that Mac OS X returns C<darwin>, not C<MacOS>. Also note that the debugger doesn't do anything special for C<darwin>. Maybe it should.
+
+=cut
+
+ elsif ( $^O eq 'MacOS' ) {
+ if ( $MacPerl::Version !~ /MPW/ ) {
+ $console =
+ "Dev:Console:Perl Debug"; # Separate window for application
+ }
+ else {
+ $console = "Dev:Console";
+ }
+ } ## end elsif ($^O eq 'MacOS')
+
+=item * VMS - use C<sys$command>.
+
+=cut
+
+ else {
+
+ # everything else is ...
+ $console = "sys\$command";
+ }
+
+=pod
+
+=back
+
+Several other systems don't use a specific console. We C<undef $console>
+for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
+with a slave editor, Epoc).
+
+=cut
+
+ if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) {
+
+ # /dev/tty is binary. use stdin for textmode
+ $console = undef;
+ }
+
+ if ( $^O eq 'NetWare' ) {
+
+ # /dev/tty is binary. use stdin for textmode
+ $console = undef;
+ }
+
+ # In OS/2, we need to use STDIN to get textmode too, even though
+ # it pretty much looks like Unix otherwise.
+ if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) )
+ { # In OS/2
+ $console = undef;
+ }
+
+ # EPOC also falls into the 'got to use STDIN' camp.
+ if ( $^O eq 'epoc' ) {
+ $console = undef;
+ }
+
+=pod
+
+If there is a TTY hanging around from a parent, we use that as the console.
+
+=cut
+
+ $console = $tty if defined $tty;
+
+=head2 SOCKET HANDLING
+
+The debugger is capable of opening a socket and carrying out a debugging
+session over the socket.
+
+If C<RemotePort> was defined in the options, the debugger assumes that it
+should try to start a debugging session on that port. It builds the socket
+and then tries to connect the input and output filehandles to it.
+
+=cut
+
+ # Handle socket stuff.
+
+ if ( defined $remoteport ) {
+
+ # If RemotePort was defined in the options, connect input and output
+ # to the socket.
+ require IO::Socket;
+ $OUT = new IO::Socket::INET(
+ Timeout => '10',
+ PeerAddr => $remoteport,
+ Proto => 'tcp',
+ );
+ if ( !$OUT ) { die "Unable to connect to remote host: $remoteport\n"; }
+ $IN = $OUT;
+ } ## end if (defined $remoteport)
+
+=pod
+
+If no C<RemotePort> was defined, and we want to create a TTY on startup,
+this is probably a situation where multiple debuggers are running (for example,
+a backticked command that starts up another debugger). We create a new IN and
+OUT filehandle, and do the necessary mojo to create a new TTY if we know how
+and if we can.
+
+=cut
+
+ # Non-socket.
+ else {
+
+ # Two debuggers running (probably a system or a backtick that invokes
+ # the debugger itself under the running one). create a new IN and OUT
+ # filehandle, and do the necessary mojo to create a new tty if we
+ # know how, and we can.
+ create_IN_OUT(4) if $CreateTTY & 4;
+ if ($console) {
+
+ # If we have a console, check to see if there are separate ins and
+ # outs to open. (They are assumed identical if not.)
+
+ my ( $i, $o ) = split /,/, $console;
+ $o = $i unless defined $o;
+
+ # read/write on in, or just read, or read on STDIN.
+ open( IN, "+<$i" )
+ || open( IN, "<$i" )
+ || open( IN, "<&STDIN" );
+
+ # read/write/create/clobber out, or write/create/clobber out,
+ # or merge with STDERR, or merge with STDOUT.
+ open( OUT, "+>$o" )
+ || open( OUT, ">$o" )
+ || open( OUT, ">&STDERR" )
+ || open( OUT, ">&STDOUT" ); # so we don't dongle stdout
+
+ } ## end if ($console)
+ elsif ( not defined $console ) {
+
+ # No console. Open STDIN.
+ open( IN, "<&STDIN" );
+
+ # merge with STDERR, or with STDOUT.
+ open( OUT, ">&STDERR" )
+ || open( OUT, ">&STDOUT" ); # so we don't dongle stdout
+ $console = 'STDIN/OUT';
+ } ## end elsif (not defined $console)
+
+ # Keep copies of the filehandles so that when the pager runs, it
+ # can close standard input without clobbering ours.
+ $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
+ } ## end elsif (from if(defined $remoteport))
+
+ # Unbuffer DB::OUT. We need to see responses right away.
+ my $previous = select($OUT);
+ $| = 1; # for DB::OUT
+ select($previous);
+
+ # Line info goes to debugger output unless pointed elsewhere.
+ # Pointing elsewhere makes it possible for slave editors to
+ # keep track of file and position. We have both a filehandle
+ # and a I/O description to keep track of.
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+ # share($LINEINFO); # <- unable to share globs
+ share($lineinfo); #
+
+=pod
+
+To finish initialization, we show the debugger greeting,
+and then call the C<afterinit()> subroutine if there is one.
+
+=cut
+
+ # Show the debugger greeting.
+ $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
+ unless ($runnonstop) {
+ local $\ = '';
+ local $, = '';
+ if ( $term_pid eq '-1' ) {
+ print $OUT "\nDaughter DB session started...\n";
+ }
+ else {
+ print $OUT "\nLoading DB routines from $header\n";
+ print $OUT (
+ "Editor support ",
+ $slave_editor ? "enabled" : "available", ".\n"
+ );
+ print $OUT
+"\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
+ } ## end else [ if ($term_pid eq '-1')
+ } ## end unless ($runnonstop)
+} ## end else [ if ($notty)
+
+# XXX This looks like a bug to me.
+# Why copy to @ARGS and then futz with @args?
+@ARGS = @ARGV;
+for (@args) {
+ # Make sure backslashes before single quotes are stripped out, and
+ # keep args unless they are numeric (XXX why?)
+ # s/\'/\\\'/g; # removed while not justified understandably
+ # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto
+}
+
+# If there was an afterinit() sub defined, call it. It will get
+# executed in our scope, so it can fiddle with debugger globals.
+if ( defined &afterinit ) { # May be defined in $rcfile
+ &afterinit();
+}
+
+# Inform us about "Stack dump during die enabled ..." in dieLevel().
+$I_m_init = 1;
+
+############################################################ Subroutines
+
+=head1 SUBROUTINES
+
+=head2 DB
+
+This gigantic subroutine is the heart of the debugger. Called before every
+statement, its job is to determine if a breakpoint has been reached, and
+stop if so; read commands from the user, parse them, and execute
+them, and then send execution off to the next statement.
+
+Note that the order in which the commands are processed is very important;
+some commands earlier in the loop will actually alter the C<$cmd> variable
+to create other commands to be executed later. This is all highly I<optimized>
+but can be confusing. Check the comments for each C<$cmd ... && do {}> to
+see what's happening in any given command.
+
+=cut
+
+sub DB {
+
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
+
+ # Check for whether we should be running continuously or not.
+ # _After_ the perl program is compiled, $single is set to 1:
+ if ( $single and not $second_time++ ) {
+
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($runnonstop) { # Disable until signal
+ # If there's any call stack in place, turn off single
+ # stepping into subs throughout the stack.
+ for ( $i = 0 ; $i <= $stack_depth ; ) {
+ $stack[ $i++ ] &= ~1;
+ }
+
+ # And we are now no longer in single-step mode.
+ $single = 0;
+
+ # If we simply returned at this point, we wouldn't get
+ # the trace info. Fall on through.
+ # return;
+ } ## end if ($runnonstop)
+
+ elsif ($ImmediateStop) {
+
+ # We are supposed to stop here; XXX probably a break.
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
+ # us into the command loop
+ }
+ } ## end if ($single and not $second_time...
+
+ # If we're in single-step mode, or an interrupt (real or fake)
+ # has occurred, turn off non-stop mode.
+ $runnonstop = 0 if $single or $signal;
+
+ # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
+ # The code being debugged may have altered them.
+ &save;
+
+ # Since DB::DB gets called after every line, we can use caller() to
+ # figure out where we last were executing. Sneaky, eh? This works because
+ # caller is returning all the extra information when called from the
+ # debugger.
+ local ( $package, $filename, $line ) = caller;
+ local $filename_ini = $filename;
+
+ # set up the context for DB::eval, so it can properly execute
+ # code on behalf of the user. We add the package in so that the
+ # code is eval'ed in the proper package (not in the debugger!).
+ local $usercontext =
+ '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;";
+
+ # Create an alias to the active file magical array to simplify
+ # the code here.
+ local (*dbline) = $main::{ '_<' . $filename };
+
+ # we need to check for pseudofiles on Mac OS (these are files
+ # not attached to a filename, but instead stored in Dev:Pseudo)
+ if ( $^O eq 'MacOS' && $#dbline < 0 ) {
+ $filename_ini = $filename = 'Dev:Pseudo';
+ *dbline = $main::{ '_<' . $filename };
+ }
+
+ # Last line in the program.
+ local $max = $#dbline;
+
+ # if we have something here, see if we should break.
+ if ( $dbline{$line}
+ && ( ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
+ {
+
+ # Stop if the stop criterion says to just stop.
+ if ( $stop eq '1' ) {
+ $signal |= 1;
+ }
+
+ # It's a conditional stop; eval it in the user's context and
+ # see if we should stop. If so, remove the one-time sigil.
+ elsif ($stop) {
+ $evalarg = "\$DB::signal |= 1 if do {$stop}";
+ &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ } ## end if ($dbline{$line} && ...
+
+ # Preserve the current stop-or-not, and see if any of the W
+ # (watch expressions) has changed.
+ my $was_signal = $signal;
+
+ # If we have any watch expressions ...
+ if ( $trace & 2 ) {
+ for ( my $n = 0 ; $n <= $#to_watch ; $n++ ) {
+ $evalarg = $to_watch[$n];
+ local $onetimeDump; # Tell DB::eval() to not output results
+
+ # Fix context DB::eval() wants to return an array, but
+ # we need a scalar here.
+ my ($val) = join( "', '", &eval );
+ $val = ( ( defined $val ) ? "'$val'" : 'undef' );
+
+ # Did it change?
+ if ( $val ne $old_watch[$n] ) {
+
+ # Yep! Show the difference, and fake an interrupt.
+ $signal = 1;
+ print $OUT <<EOP;
+Watchpoint $n:\t$to_watch[$n] changed:
+ old value:\t$old_watch[$n]
+ new value:\t$val
+EOP
+ $old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for (my $n = 0 ; $n <= ...
+ } ## end if ($trace & 2)
+
+=head2 C<watchfunction()>
+
+C<watchfunction()> is a function that can be defined by the user; it is a
+function which will be run on each entry to C<DB::DB>; it gets the
+current package, filename, and line as its parameters.
+
+The watchfunction can do anything it likes; it is executing in the
+debugger's context, so it has access to all of the debugger's internal
+data structures and functions.
+
+C<watchfunction()> can control the debugger's actions. Any of the following
+will cause the debugger to return control to the user's program after
+C<watchfunction()> executes:
+
+=over 4
+
+=item *
+
+Returning a false value from the C<watchfunction()> itself.
+
+=item *
+
+Altering C<$single> to a false value.
+
+=item *
+
+Altering C<$signal> to a false value.
+
+=item *
+
+Turning off the C<4> bit in C<$trace> (this also disables the
+check for C<watchfunction()>. This can be done with
+
+ $trace &= ~4;
+
+=back
+
+=cut
+
+ # If there's a user-defined DB::watchfunction, call it with the
+ # current package, filename, and line. The function executes in
+ # the DB:: package.
+ if ( $trace & 4 ) { # User-installed watch
+ return
+ if watchfunction( $package, $filename, $line )
+ and not $single
+ and not $was_signal
+ and not( $trace & ~4 );
+ } ## end if ($trace & 4)
+
+ # Pick up any alteration to $signal in the watchfunction, and
+ # turn off the signal now.
+ $was_signal = $signal;
+ $signal = 0;
+
+=head2 GETTING READY TO EXECUTE COMMANDS
+
+The debugger decides to take control if single-step mode is on, the
+C<t> command was entered, or the user generated a signal. If the program
+has fallen off the end, we set things up so that entering further commands
+won't cause trouble, and we say that the program is over.
+
+=cut
+
+ # Check to see if we should grab control ($single true,
+ # trace set appropriately, or we got a signal).
+ if ( $single || ( $trace & 1 ) || $was_signal ) {
+
+ # Yes, grab control.
+ if ($slave_editor) {
+
+ # Tell the editor to update its position.
+ $position = "\032\032$filename:$line:0\n";
+ print_lineinfo($position);
+ }
+
+=pod
+
+Special check: if we're in package C<DB::fake>, we've gone through the
+C<END> block at least once. We set up everything so that we can continue
+to enter commands and have a valid context to be in.
+
+=cut
+
+ elsif ( $package eq 'DB::fake' ) {
+
+ # Fallen off the end already.
+ $term || &setterm;
+ print_help(<<EOP);
+Debugged program terminated. Use B<q> to quit or B<R> to restart,
+ use B<o> I<inhibit_exit> to avoid stopping after program termination,
+ B<h q>, B<h R> or B<h o> to get additional info.
+EOP
+
+ # Set the DB::eval context appropriately.
+ $package = 'main';
+ $usercontext =
+ '($@, $!, $^E, $,, $/, $\, $^W) = @saved;'
+ . "package $package;"; # this won't let them modify, alas
+ } ## end elsif ($package eq 'DB::fake')
+
+=pod
+
+If the program hasn't finished executing, we scan forward to the
+next executable line, print that out, build the prompt from the file and line
+number information, and print that.
+
+=cut
+
+ else {
+
+ # Still somewhere in the midst of execution. Set up the
+ # debugger prompt.
+ $sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
+ # Perl 5 ones (sorry, we don't print Klingon
+ #module names)
+
+ $prefix = $sub =~ /::/ ? "" : "${'package'}::";
+ $prefix .= "$sub($filename:";
+ $after = ( $dbline[$line] =~ /\n$/ ? '' : "\n" );
+
+ # Break up the prompt if it's really long.
+ if ( length($prefix) > 30 ) {
+ $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
+ $prefix = "";
+ $infix = ":\t";
+ }
+ else {
+ $infix = "):\t";
+ $position = "$prefix$line$infix$dbline[$line]$after";
+ }
+
+ # Print current line info, indenting if necessary.
+ if ($frame) {
+ print_lineinfo( ' ' x $stack_depth,
+ "$line:\t$dbline[$line]$after" );
+ }
+ else {
+ print_lineinfo($position);
+ }
+
+ # Scan forward, stopping at either the end or the next
+ # unbreakable line.
+ for ( $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
+ { #{ vi
+
+ # Drop out on null statements, block closers, and comments.
+ last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
+
+ # Drop out if the user interrupted us.
+ last if $signal;
+
+ # Append a newline if the line doesn't have one. Can happen
+ # in eval'ed text, for instance.
+ $after = ( $dbline[$i] =~ /\n$/ ? '' : "\n" );
+
+ # Next executable line.
+ $incr_pos = "$prefix$i$infix$dbline[$i]$after";
+ $position .= $incr_pos;
+ if ($frame) {
+
+ # Print it indented if tracing is on.
+ print_lineinfo( ' ' x $stack_depth,
+ "$i:\t$dbline[$i]$after" );
+ }
+ else {
+ print_lineinfo($incr_pos);
+ }
+ } ## end for ($i = $line + 1 ; $i...
+ } ## end else [ if ($slave_editor)
+ } ## end if ($single || ($trace...
+
+=pod
+
+If there's an action to be executed for the line we stopped at, execute it.
+If there are any preprompt actions, execute those as well.
+
+=cut
+
+ # If there's an action, do it now.
+ $evalarg = $action, &eval if $action;
+
+ # Are we nested another level (e.g., did we evaluate a function
+ # that had a breakpoint in it at the debugger prompt)?
+ if ( $single || $was_signal ) {
+
+ # Yes, go down a level.
+ local $level = $level + 1;
+
+ # Do any pre-prompt actions.
+ foreach $evalarg (@$pre) {
+ &eval;
+ }
+
+ # Complain about too much recursion if we passed the limit.
+ print $OUT $stack_depth . " levels deep in subroutine calls!\n"
+ if $single & 4;
+
+ # The line we're currently on. Set $incr to -1 to stay here
+ # until we get a command that tells us to advance.
+ $start = $line;
+ $incr = -1; # for backward motion.
+
+ # Tack preprompt debugger actions ahead of any actual input.
+ @typeahead = ( @$pretype, @typeahead );
+
+=head2 WHERE ARE WE?
+
+XXX Relocate this section?
+
+The debugger normally shows the line corresponding to the current line of
+execution. Sometimes, though, we want to see the next line, or to move elsewhere
+in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
+
+C<$incr> controls by how many lines the I<current> line should move forward
+after a command is executed. If set to -1, this indicates that the I<current>
+line shouldn't change.
+
+C<$start> is the I<current> line. It is used for things like knowing where to
+move forwards or backwards from when doing an C<L> or C<-> command.
+
+C<$max> tells the debugger where the last line of the current file is. It's
+used to terminate loops most often.
+
+=head2 THE COMMAND LOOP
+
+Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
+in two parts:
+
+=over 4
+
+=item *
+
+The outer part of the loop, starting at the C<CMD> label. This loop
+reads a command and then executes it.
+
+=item *
+
+The inner part of the loop, starting at the C<PIPE> label. This part
+is wholly contained inside the C<CMD> block and only executes a command.
+Used to handle commands running inside a pager.
+
+=back
+
+So why have two labels to restart the loop? Because sometimes, it's easier to
+have a command I<generate> another command and then re-execute the loop to do
+the new command. This is faster, but perhaps a bit more convoluted.
+
+=cut
+
+ # The big command dispatch loop. It keeps running until the
+ # user yields up control again.
+ #
+ # If we have a terminal for input, and we get something back
+ # from readline(), keep on processing.
+ CMD:
+ while (
+
+ # We have a terminal, or can get one ...
+ ( $term || &setterm ),
+
+ # ... and it belogs to this PID or we get one for this PID ...
+ ( $term_pid == $$ or resetterm(1) ),
+
+ # ... and we got a line of command input ...
+ defined(
+ $cmd = &readline(
+ "$pidprompt $tid DB"
+ . ( '<' x $level )
+ . ( $#hist + 1 )
+ . ( '>' x $level ) . " "
+ )
+ )
+ )
+ {
+
+ share($cmd);
+ # ... try to execute the input as debugger commands.
+
+ # Don't stop running.
+ $single = 0;
+
+ # No signal is active.
+ $signal = 0;
+
+ # Handle continued commands (ending with \):
+ $cmd =~ s/\\$/\n/ && do {
+ $cmd .= &readline(" cont: ");
+ redo CMD;
+ };
+
+=head4 The null command
+
+A newline entered by itself means I<re-execute the last command>. We grab the
+command out of C<$laststep> (where it was recorded previously), and copy it
+back into C<$cmd> to be executed below. If there wasn't any previous command,
+we'll do nothing below (no command will match). If there was, we also save it
+in the command history and fall through to allow the command parsing to pick
+it up.
+
+=cut
+
+ # Empty input means repeat the last command.
+ $cmd =~ /^$/ && ( $cmd = $laststep );
+ chomp($cmd); # get rid of the annoying extra newline
+ push( @hist, $cmd ) if length($cmd) > 1;
+ push( @truehist, $cmd );
+ share(@hist);
+ share(@truehist);
+
+ # This is a restart point for commands that didn't arrive
+ # via direct user input. It allows us to 'redo PIPE' to
+ # re-execute command processing without reading a new command.
+ PIPE: {
+ $cmd =~ s/^\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
+ ($i) = split( /\s+/, $cmd );
+
+=head3 COMMAND ALIASES
+
+The debugger can create aliases for commands (these are stored in the
+C<%alias> hash). Before a command is executed, the command loop looks it up
+in the alias hash and substitutes the contents of the alias for the command,
+completely replacing it.
+
+=cut
+
+ # See if there's an alias for the command, and set it up if so.
+ if ( $alias{$i} ) {
+
+ # Squelch signal handling; we want to keep control here
+ # if something goes loco during the alias eval.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # This is a command, so we eval it in the DEBUGGER's
+ # scope! Otherwise, we can't see the special debugger
+ # variables, or get to the debugger's subs. (Well, we
+ # _could_, but why make it even more complicated?)
+ eval "\$cmd =~ $alias{$i}";
+ if ($@) {
+ local $\ = '';
+ print $OUT "Couldn't evaluate `$i' alias: $@";
+ next CMD;
+ }
+ } ## end if ($alias{$i})
+
+=head3 MAIN-LINE COMMANDS
+
+All of these commands work up to and after the program being debugged has
+terminated.
+
+=head4 C<q> - quit
+
+Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
+try to execute further, cleaning any restart-related stuff out of the
+environment, and executing with the last value of C<$?>.
+
+=cut
+
+ $cmd =~ /^q$/ && do {
+ $fall_off_end = 1;
+ clean_ENV();
+ exit $?;
+ };
+
+=head4 C<t> - trace
+
+Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
+
+=cut
+
+ $cmd =~ /^t$/ && do {
+ $trace ^= 1;
+ local $\ = '';
+ print $OUT "Trace = "
+ . ( ( $trace & 1 ) ? "on" : "off" ) . "\n";
+ next CMD;
+ };
+
+=head4 C<S> - list subroutines matching/not matching a pattern
+
+Walks through C<%sub>, checking to see whether or not to print the name.
+
+=cut
+
+ $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
+
+ $Srev = defined $2; # Reverse scan?
+ $Spatt = $3; # The pattern (if any) to use.
+ $Snocheck = !defined $1; # No args - print all subs.
+
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
+
+ # Search through the debugger's magical hash of subs.
+ # If $nocheck is true, just print the sub name.
+ # Otherwise, check it against the pattern. We then use
+ # the XOR trick to reverse the condition as required.
+ foreach $subname ( sort( keys %sub ) ) {
+ if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
+ print $OUT $subname, "\n";
+ }
+ }
+ next CMD;
+ };
+
+=head4 C<X> - list variables in current package
+
+Since the C<V> command actually processes this, just change this to the
+appropriate C<V> command and fall through.
+
+=cut
+
+ $cmd =~ s/^X\b/V $package/;
+
+=head4 C<V> - list variables
+
+Uses C<dumpvar.pl> to dump out the current values for selected variables.
+
+=cut
+
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ $cmd =~ /^V$/ && do {
+ $cmd = "V $package";
+ };
+
+ # V - show variables in package.
+ $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ local ($savout) = select($OUT);
+
+ # Grab package name and variables to dump.
+ $packname = $1;
+ @vars = split( ' ', $2 );
+
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ if ( defined &main::dumpvar ) {
+
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment, along with return values.
+ local $frame = 0;
+ local $doret = -2;
+
+ # must detect sigpipe failures - not catching
+ # then will cause the debugger to die.
+ eval {
+ &main::dumpvar(
+ $packname,
+ defined $option{dumpDepth}
+ ? $option{dumpDepth}
+ : -1, # assume -1 unless specified
+ @vars
+ );
+ };
+
+ # The die doesn't need to include the $@, because
+ # it will automatically get propagated for us.
+ if ($@) {
+ die unless $@ =~ /dumpvar print failed/;
+ }
+ } ## end if (defined &main::dumpvar)
+ else {
+
+ # Couldn't load dumpvar.
+ print $OUT "dumpvar.pl not available.\n";
+ }
+
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ };
+
+=head4 C<x> - evaluate and print an expression
+
+Hands the expression off to C<DB::eval>, setting it up to print the value
+via C<dumpvar.pl> instead of just printing it directly.
+
+=cut
+
+ $cmd =~ s/^x\b/ / && do { # Remainder gets done by DB::eval()
+ $onetimeDump = 'dump'; # main::dumpvar shows the output
+
+ # handle special "x 3 blah" syntax XXX propagate
+ # doc back to special variables.
+ if ( $cmd =~ s/^\s*(\d+)(?=\s)/ / ) {
+ $onetimedumpDepth = $1;
+ }
+ };
+
+=head4 C<m> - print methods
+
+Just uses C<DB::methods> to determine what methods are available.
+
+=cut
+
+ $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
+ methods($1);
+ next CMD;
+ };
+
+ # m expr - set up DB::eval to do the work
+ $cmd =~ s/^m\b/ / && do { # Rest gets done by DB::eval()
+ $onetimeDump = 'methods'; # method output gets used there
+ };
+
+=head4 C<f> - switch files
+
+=cut
+
+ $cmd =~ /^f\b\s*(.*)/ && do {
+ $file = $1;
+ $file =~ s/\s+$//;
+
+ # help for no arguments (old-style was return from sub).
+ if ( !$file ) {
+ print $OUT
+ "The old f command is now the r command.\n"; # hint
+ print $OUT "The new f command switches filenames.\n";
+ next CMD;
+ } ## end if (!$file)
+
+ # if not in magic file list, try a close match.
+ if ( !defined $main::{ '_<' . $file } ) {
+ if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
+ {
+ $try = substr( $try, 2 );
+ print $OUT "Choosing $try matching `$file':\n";
+ $file = $try;
+ }
+ } ## end if (($try) = grep(m#^_<.*$file#...
+ } ## end if (!defined $main::{ ...
+
+ # If not successfully switched now, we failed.
+ if ( !defined $main::{ '_<' . $file } ) {
+ print $OUT "No file matching `$file' is loaded.\n";
+ next CMD;
+ }
+
+ # We switched, so switch the debugger internals around.
+ elsif ( $file ne $filename ) {
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } ## end elsif ($file ne $filename)
+
+ # We didn't switch; say we didn't.
+ else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ };
+
+=head4 C<.> - return to last-executed line.
+
+We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
+and then we look up the line in the magical C<%dbline> hash.
+
+=cut
+
+ # . command.
+ $cmd =~ /^\.$/ && do {
+ $incr = -1; # stay at current line
+
+ # Reset everything to the old location.
+ $start = $line;
+ $filename = $filename_ini;
+ *dbline = $main::{ '_<' . $filename };
+ $max = $#dbline;
+
+ # Now where are we?
+ print_lineinfo($position);
+ next CMD;
+ };
+
+=head4 C<-> - back one window
+
+We change C<$start> to be one window back; if we go back past the first line,
+we set it to be the first line. We ser C<$incr> to put us back at the
+currently-executing line, and then put a C<l $start +> (list one window from
+C<$start>) in C<$cmd> to be executed later.
+
+=cut
+
+ # - - back a window.
+ $cmd =~ /^-$/ && do {
+
+ # back up by a window; go to 1 if back too far.
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
+
+ # Generate and execute a "l +" command (handled below).
+ $cmd = 'l ' . ($start) . '+';
+ };
+
+=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, {, {{>
+
+In Perl 5.8.0, a realignment of the commands was done to fix up a number of
+problems, most notably that the default case of several commands destroying
+the user's work in setting watchpoints, actions, etc. We wanted, however, to
+retain the old commands for those who were used to using them or who preferred
+them. At this point, we check for the new commands and call C<cmd_wrapper> to
+deal with them instead of processing them in-line.
+
+=cut
+
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ $cmd =~ /^([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
+ &cmd_wrapper( $1, $2, $line );
+ next CMD;
+ };
+
+=head4 C<y> - List lexicals in higher scope
+
+Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
+above the current one and then displays then using C<dumpvar.pl>.
+
+=cut
+
+ $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
+
+ # See if we've got the necessary support.
+ eval { require PadWalker; PadWalker->VERSION(0.08) }
+ or &warn(
+ $@ =~ /locate/
+ ? "PadWalker module not found - please install\n"
+ : $@
+ )
+ and next CMD;
+
+ # Load up dumpvar if we don't have it. If we can, that is.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ defined &main::dumpvar
+ or print $OUT "dumpvar.pl not available.\n"
+ and next CMD;
+
+ # Got all the modules we need. Find them and print them.
+ my @vars = split( ' ', $2 || '' );
+
+ # Find the pad.
+ my $h = eval { PadWalker::peek_my( ( $1 || 0 ) + 1 ) };
+
+ # Oops. Can't find it.
+ $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
+
+ # Show the desired vars with dumplex().
+ my $savout = select($OUT);
+
+ # Have dumplex dump the lexicals.
+ dumpvar::dumplex( $_, $h->{$_},
+ defined $option{dumpDepth} ? $option{dumpDepth} : -1,
+ @vars )
+ for sort keys %$h;
+ select($savout);
+ next CMD;
+ };
+
+=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
+
+All of the commands below this point don't work after the program being
+debugged has ended. All of them check to see if the program has ended; this
+allows the commands to be relocated without worrying about a 'line of
+demarcation' above which commands can be entered anytime, and below which
+they can't.
+
+=head4 C<n> - single step, but don't trace down into subs
+
+Done by setting C<$single> to 2, which forces subs to execute straight through
+when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
+so a null command knows what to re-execute.
+
+=cut
+
+ # n - next
+ $cmd =~ /^n$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
+
+ # Single step, but don't enter subs.
+ $single = 2;
+
+ # Save for empty command (repeat last).
+ $laststep = $cmd;
+ last CMD;
+ };
+
+=head4 C<s> - single-step, entering subs
+
+Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
+subs. Also saves C<s> as C<$lastcmd>.
+
+=cut
+
+ # s - single step.
+ $cmd =~ /^s$/ && do {
+
+ # Get out and restart the command loop if program
+ # has finished.
+ end_report(), next CMD if $finished and $level <= 1;
+
+ # Single step should enter subs.
+ $single = 1;
+
+ # Save for empty command (repeat last).
+ $laststep = $cmd;
+ last CMD;
+ };
+
+=head4 C<c> - run continuously, setting an optional breakpoint
+
+Most of the code for this command is taken up with locating the optional
+breakpoint, which is either a subroutine name or a line number. We set
+the appropriate one-time-break in C<@dbline> and then turn off single-stepping
+in this and all call levels above this one.
+
+=cut
+
+ # c - start continuous execution.
+ $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
+
+ # Hey, show's over. The debugged program finished
+ # executing already.
+ end_report(), next CMD if $finished and $level <= 1;
+
+ # Capture the place to put a one-time break.
+ $subname = $i = $1;
+
+ # Probably not needed, since we finish an interactive
+ # sub-session anyway...
+ # local $filename = $filename;
+ # local *dbline = *dbline; # XXX Would this work?!
+ #
+ # The above question wonders if localizing the alias
+ # to the magic array works or not. Since it's commented
+ # out, we'll just leave that to speculation for now.
+
+ # If the "subname" isn't all digits, we'll assume it
+ # is a subroutine name, and try to find it.
+ if ( $subname =~ /\D/ ) { # subroutine name
+ # Qualify it to the current package unless it's
+ # already qualified.
+ $subname = $package . "::" . $subname
+ unless $subname =~ /::/;
+
+ # find_sub will return "file:line_number" corresponding
+ # to where the subroutine is defined; we call find_sub,
+ # break up the return value, and assign it in one
+ # operation.
+ ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
+
+ # Force the line number to be numeric.
+ $i += 0;
+
+ # If we got a line number, we found the sub.
+ if ($i) {
+
+ # Switch all the debugger's internals around so
+ # we're actually working with that file.
+ $filename = $file;
+ *dbline = $main::{ '_<' . $filename };
+
+ # Mark that there's a breakpoint in this file.
+ $had_breakpoints{$filename} |= 1;
+
+ # Scan forward to the first executable line
+ # after the 'sub whatever' line.
+ $max = $#dbline;
+ ++$i while $dbline[$i] == 0 && $i < $max;
+ } ## end if ($i)
+
+ # We didn't find a sub by that name.
+ else {
+ print $OUT "Subroutine $subname not found.\n";
+ next CMD;
+ }
+ } ## end if ($subname =~ /\D/)
+
+ # At this point, either the subname was all digits (an
+ # absolute line-break request) or we've scanned through
+ # the code following the definition of the sub, looking
+ # for an executable, which we may or may not have found.
+ #
+ # If $i (which we set $subname from) is non-zero, we
+ # got a request to break at some line somewhere. On
+ # one hand, if there wasn't any real subroutine name
+ # involved, this will be a request to break in the current
+ # file at the specified line, so we have to check to make
+ # sure that the line specified really is breakable.
+ #
+ # On the other hand, if there was a subname supplied, the
+ # preceding block has moved us to the proper file and
+ # location within that file, and then scanned forward
+ # looking for the next executable line. We have to make
+ # sure that one was found.
+ #
+ # On the gripping hand, we can't do anything unless the
+ # current value of $i points to a valid breakable line.
+ # Check that.
+ if ($i) {
+
+ # Breakable?
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+
+ # Yes. Set up the one-time-break sigil.
+ $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ } ## end if ($i)
+
+ # Turn off stack tracing from here up.
+ for ( $i = 0 ; $i <= $stack_depth ; ) {
+ $stack[ $i++ ] &= ~1;
+ }
+ last CMD;
+ };
+
+=head4 C<r> - return from a subroutine
+
+For C<r> to work properly, the debugger has to stop execution again
+immediately after the return is executed. This is done by forcing
+single-stepping to be on in the call level above the current one. If
+we are printing return values when a C<r> is executed, set C<$doret>
+appropriately, and force us out of the command loop.
+
+=cut
+
+ # r - return from the current subroutine.
+ $cmd =~ /^r$/ && do {
+
+ # Can't do anythign if the program's over.
+ end_report(), next CMD if $finished and $level <= 1;
+
+ # Turn on stack trace.
+ $stack[$stack_depth] |= 1;
+
+ # Print return value unless the stack is empty.
+ $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
+ last CMD;
+ };
+
+=head4 C<T> - stack trace
+
+Just calls C<DB::print_trace>.
+
+=cut
+
+ $cmd =~ /^T$/ && do {
+ print_trace( $OUT, 1 ); # skip DB
+ next CMD;
+ };
+
+=head4 C<w> - List window around current line.
+
+Just calls C<DB::cmd_w>.
+
+=cut
+
+ $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w( 'w', $1 ); next CMD; };
+
+=head4 C<W> - watch-expression processing.
+
+Just calls C<DB::cmd_W>.
+
+=cut
+
+ $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W( 'W', $1 ); next CMD; };
+
+=head4 C</> - search forward for a string in the source
+
+We take the argument and treat it as a pattern. If it turns out to be a
+bad one, we return the error we got from trying to C<eval> it and exit.
+If not, we create some code to do the search and C<eval> it so it can't
+mess us up.
+
+=cut
+
+ $cmd =~ /^\/(.*)$/ && do {
+
+ # The pattern as a string.
+ $inpat = $1;
+
+ # Remove the final slash.
+ $inpat =~ s:([^\\])/$:$1:;
+
+ # If the pattern isn't null ...
+ if ( $inpat ne "" ) {
+
+ # Turn of warn and die procesing for a bit.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Create the pattern.
+ eval '$inpat =~ m' . "\a$inpat\a";
+ if ( $@ ne "" ) {
+
+ # Oops. Bad pattern. No biscuit.
+ # Print the eval error and go back for more
+ # commands.
+ print $OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ } ## end if ($inpat ne "")
+
+ # Set up to stop on wrap-around.
+ $end = $start;
+
+ # Don't move off the current line.
+ $incr = -1;
+
+ # Done in eval so nothing breaks if the pattern
+ # does something weird.
+ eval '
+ for (;;) {
+ # Move ahead one line.
+ ++$start;
+
+ # Wrap if we pass the last line.
+ $start = 1 if ($start > $max);
+
+ # Stop if we have gotten back to this line again,
+ last if ($start == $end);
+
+ # A hit! (Note, though, that we are doing
+ # case-insensitive matching. Maybe a qr//
+ # expression would be better, so the user could
+ # do case-sensitive matching if desired.
+ if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
+ if ($slave_editor) {
+ # Handle proper escaping in the slave.
+ print $OUT "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Just print the line normally.
+ print $OUT "$start:\t",$dbline[$start],"\n";
+ }
+ # And quit since we found something.
+ last;
+ }
+ } ';
+
+ # If we wrapped, there never was a match.
+ print $OUT "/$pat/: not found\n" if ( $start == $end );
+ next CMD;
+ };
+
+=head4 C<?> - search backward for a string in the source
+
+Same as for C</>, except the loop runs backwards.
+
+=cut
+
+ # ? - backward pattern search.
+ $cmd =~ /^\?(.*)$/ && do {
+
+ # Get the pattern, remove trailing question mark.
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+
+ # If we've got one ...
+ if ( $inpat ne "" ) {
+
+ # Turn off die & warn handlers.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ eval '$inpat =~ m' . "\a$inpat\a";
+
+ if ( $@ ne "" ) {
+
+ # Ouch. Not good. Print the error.
+ print $OUT $@;
+ next CMD;
+ }
+ $pat = $inpat;
+ } ## end if ($inpat ne "")
+
+ # Where we are now is where to stop after wraparound.
+ $end = $start;
+
+ # Don't move away from this line.
+ $incr = -1;
+
+ # Search inside the eval to prevent pattern badness
+ # from killing us.
+ eval '
+ for (;;) {
+ # Back up a line.
+ --$start;
+
+ # Wrap if we pass the first line.
+
+ $start = $max if ($start <= 0);
+
+ # Quit if we get back where we started,
+ last if ($start == $end);
+
+ # Match?
+ if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
+ if ($slave_editor) {
+ # Yep, follow slave editor requirements.
+ print $OUT "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Yep, just print normally.
+ print $OUT "$start:\t",$dbline[$start],"\n";
+ }
+
+ # Found, so done.
+ last;
+ }
+ } ';
+
+ # Say we failed if the loop never found anything,
+ print $OUT "?$pat?: not found\n" if ( $start == $end );
+ next CMD;
+ };
+
+=head4 C<$rc> - Recall command
+
+Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
+that the terminal supports history). It find the the command required, puts it
+into C<$cmd>, and redoes the loop to execute it.
+
+=cut
+
+ # $rc - recall command.
+ $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
+
+ # No arguments, take one thing off history.
+ pop(@hist) if length($cmd) > 1;
+
+ # Relative (- found)?
+ # Y - index back from most recent (by 1 if bare minus)
+ # N - go to that particular command slot or the last
+ # thing if nothing following.
+ $i = $1 ? ( $#hist - ( $2 || 1 ) ) : ( $2 || $#hist );
+
+ # Pick out the command desired.
+ $cmd = $hist[$i];
+
+ # Print the command to be executed and restart the loop
+ # with that command in the buffer.
+ print $OUT $cmd, "\n";
+ redo CMD;
+ };
+
+=head4 C<$sh$sh> - C<system()> command
+
+Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
+C<STDOUT> from getting messed up.
+
+=cut
+
+ # $sh$sh - run a shell command (if it's all ASCII).
+ # Can't run shell commands with Unicode in the debugger, hmm.
+ $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
+
+ # System it.
+ &system($1);
+ next CMD;
+ };
+
+=head4 C<$rc I<pattern> $rc> - Search command history
+
+Another command to manipulate C<@hist>: this one searches it with a pattern.
+If a command is found, it is placed in C<$cmd> and executed via C<redo>.
+
+=cut
+
+ # $rc pattern $rc - find a command in the history.
+ $cmd =~ /^$rc([^$rc].*)$/ && do {
+
+ # Create the pattern to use.
+ $pat = "^$1";
+
+ # Toss off last entry if length is >1 (and it always is).
+ pop(@hist) if length($cmd) > 1;
+
+ # Look backward through the history.
+ for ( $i = $#hist ; $i ; --$i ) {
+
+ # Stop if we find it.
+ last if $hist[$i] =~ /$pat/;
+ }
+
+ if ( !$i ) {
+
+ # Never found it.
+ print $OUT "No such command!\n\n";
+ next CMD;
+ }
+
+ # Found it. Put it in the buffer, print it, and process it.
+ $cmd = $hist[$i];
+ print $OUT $cmd, "\n";
+ redo CMD;
+ };
+
+=head4 C<$sh> - Invoke a shell
+
+Uses C<DB::system> to invoke a shell.
+
+=cut
+
+ # $sh - start a shell.
+ $cmd =~ /^$sh$/ && do {
+
+ # Run the user's shell. If none defined, run Bourne.
+ # We resume execution when the shell terminates.
+ &system( $ENV{SHELL} || "/bin/sh" );
+ next CMD;
+ };
+
+=head4 C<$sh I<command>> - Force execution of a command in a shell
+
+Like the above, but the command is passed to the shell. Again, we use
+C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
+
+=cut
+
+ # $sh command - start a shell and run a command in it.
+ $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
+
+ # XXX: using csh or tcsh destroys sigint retvals!
+ #&system($1); # use this instead
+
+ # use the user's shell, or Bourne if none defined.
+ &system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
+ next CMD;
+ };
+
+=head4 C<H> - display commands in history
+
+Prints the contents of C<@hist> (if any).
+
+=cut
+
+ $cmd =~ /^H\b\s*\*/ && do {
+ @hist = @truehist = ();
+ print $OUT "History cleansed\n";
+ next CMD;
+ };
+
+ $cmd =~ /^H\b\s*(-(\d+))?/ && do {
+
+ # Anything other than negative numbers is ignored by
+ # the (incorrect) pattern, so this test does nothing.
+ $end = $2 ? ( $#hist - $2 ) : 0;
+
+ # Set to the minimum if less than zero.
+ $hist = 0 if $hist < 0;
+
+ # Start at the end of the array.
+ # Stay in while we're still above the ending value.
+ # Tick back by one each time around the loop.
+ for ( $i = $#hist ; $i > $end ; $i-- ) {
+
+ # Print the command unless it has no arguments.
+ print $OUT "$i: ", $hist[$i], "\n"
+ unless $hist[$i] =~ /^.?$/;
+ }
+ next CMD;
+ };
+
+=head4 C<man, doc, perldoc> - look up documentation
+
+Just calls C<runman()> to print the appropriate document.
+
+=cut
+
+ # man, perldoc, doc - show manual pages.
+ $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
+ runman($1);
+ next CMD;
+ };
+
+=head4 C<p> - print
+
+Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
+the bottom of the loop.
+
+=cut
+
+ # p - print (no args): print $_.
+ $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
+
+ # p - print the given expression.
+ $cmd =~ s/^p\b/print {\$DB::OUT} /;
+
+=head4 C<=> - define command alias
+
+Manipulates C<%alias> to add or list command aliases.
+
+=cut
+
+ # = - set up a command alias.
+ $cmd =~ s/^=\s*// && do {
+ my @keys;
+ if ( length $cmd == 0 ) {
+
+ # No args, get current aliases.
+ @keys = sort keys %alias;
+ }
+ elsif ( my ( $k, $v ) = ( $cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
+
+ # Creating a new alias. $k is alias name, $v is
+ # alias value.
+
+ # can't use $_ or kill //g state
+ for my $x ( $k, $v ) {
+
+ # Escape "alarm" characters.
+ $x =~ s/\a/\\a/g;
+ }
+
+ # Substitute key for value, using alarm chars
+ # as separators (which is why we escaped them in
+ # the command).
+ $alias{$k} = "s\a$k\a$v\a";
+
+ # Turn off standard warn and die behavior.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Is it valid Perl?
+ unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
+
+ # Nope. Bad alias. Say so and get out.
+ print $OUT "Can't alias $k to $v: $@\n";
+ delete $alias{$k};
+ next CMD;
+ }
+
+ # We'll only list the new one.
+ @keys = ($k);
+ } ## end elsif (my ($k, $v) = ($cmd...
+
+ # The argument is the alias to list.
+ else {
+ @keys = ($cmd);
+ }
+
+ # List aliases.
+ for my $k (@keys) {
+
+ # Messy metaquoting: Trim the substiution code off.
+ # We use control-G as the delimiter because it's not
+ # likely to appear in the alias.
+ if ( ( my $v = $alias{$k} ) =~ ss\a$k\a(.*)\a$1 ) {
+
+ # Print the alias.
+ print $OUT "$k\t= $1\n";
+ }
+ elsif ( defined $alias{$k} ) {
+
+ # Couldn't trim it off; just print the alias code.
+ print $OUT "$k\t$alias{$k}\n";
+ }
+ else {
+
+ # No such, dude.
+ print "No alias for $k\n";
+ }
+ } ## end for my $k (@keys)
+ next CMD;
+ };
+
+=head4 C<source> - read commands from a file.
+
+Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
+pick it up.
+
+=cut
+
+ # source - read commands from a file (or pipe!) and execute.
+ $cmd =~ /^source\s+(.*\S)/ && do {
+ if ( open my $fh, $1 ) {
+
+ # Opened OK; stick it in the list of file handles.
+ push @cmdfhs, $fh;
+ }
+ else {
+
+ # Couldn't open it.
+ &warn("Can't execute `$1': $!\n");
+ }
+ next CMD;
+ };
+
+=head4 C<save> - send current history to a file
+
+Takes the complete history, (not the shrunken version you see with C<H>),
+and saves it to the given filename, so it can be replayed using C<source>.
+
+Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
+
+=cut
+
+ # save source - write commands to a file for later use
+ $cmd =~ /^save\s*(.*)$/ && do {
+ my $file = $1 || '.perl5dbrc'; # default?
+ if ( open my $fh, "> $file" ) {
+
+ # chomp to remove extraneous newlines from source'd files
+ chomp( my @truelist =
+ map { m/^\s*(save|source)/ ? "#$_" : $_ }
+ @truehist );
+ print $fh join( "\n", @truelist );
+ print "commands saved in $file\n";
+ }
+ else {
+ &warn("Can't save debugger commands in '$1': $!\n");
+ }
+ next CMD;
+ };
+
+=head4 C<R> - restart
+
+Restart the debugger session.
+
+=head4 C<rerun> - rerun the current session
+
+Return to any given position in the B<true>-history list
+
+=cut
+
+ # R - restart execution.
+ # rerun - controlled restart execution.
+ $cmd =~ /^(R|rerun\s*(.*))$/ && do {
+ my @args = ($1 eq 'R' ? restart() : rerun($2));
+
+ # Close all non-system fds for a clean restart. A more
+ # correct method would be to close all fds that were not
+ # open when the process started, but this seems to be
+ # hard. See "debugger 'R'estart and open database
+ # connections" on p5p.
+
+ my $max_fd = 1024; # default if POSIX can't be loaded
+ if (eval { require POSIX }) {
+ $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX());
+ }
+
+ if (defined $max_fd) {
+ foreach ($^F+1 .. $max_fd-1) {
+ next unless open FD_TO_CLOSE, "<&=$_";
+ close(FD_TO_CLOSE);
+ }
+ }
+
+ # And run Perl again. We use exec() to keep the
+ # PID stable (and that way $ini_pids is still valid).
+ exec(@args) || print $OUT "exec failed: $!\n";
+
+ last CMD;
+ };
+
+=head4 C<|, ||> - pipe output through the pager.
+
+For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
+(the program's standard output). For C<||>, we only save C<OUT>. We open a
+pipe to the pager (restoring the output filehandles if this fails). If this
+is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
+set C<$signal>, sending us back into the debugger.
+
+We then trim off the pipe symbols and C<redo> the command loop at the
+C<PIPE> label, causing us to evaluate the command in C<$cmd> without
+reading another.
+
+=cut
+
+ # || - run command in the pager, with output to DB::OUT.
+ $cmd =~ /^\|\|?\s*[^|]/ && do {
+ if ( $pager =~ /^\|/ ) {
+
+ # Default pager is into a pipe. Redirect I/O.
+ open( SAVEOUT, ">&STDOUT" )
+ || &warn("Can't save STDOUT");
+ open( STDOUT, ">&OUT" )
+ || &warn("Can't redirect STDOUT");
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Not into a pipe. STDOUT is safe.
+ open( SAVEOUT, ">&OUT" ) || &warn("Can't save DB::OUT");
+ }
+
+ # Fix up environment to record we have less if so.
+ fix_less();
+
+ unless ( $piped = open( OUT, $pager ) ) {
+
+ # Couldn't open pipe to pager.
+ &warn("Can't pipe output to `$pager'");
+ if ( $pager =~ /^\|/ ) {
+
+ # Redirect I/O back again.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || &warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || &warn("Can't restore STDOUT");
+ close(SAVEOUT);
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Redirect I/O. STDOUT already safe.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || &warn("Can't restore DB::OUT");
+ }
+ next CMD;
+ } ## end unless ($piped = open(OUT,...
+
+ # Set up broken-pipe handler if necessary.
+ $SIG{PIPE} = \&DB::catch
+ if $pager =~ /^\|/
+ && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
+
+ # Save current filehandle, unbuffer out, and put it back.
+ $selected = select(OUT);
+ $| = 1;
+
+ # Don't put it back if pager was a pipe.
+ select($selected), $selected = "" unless $cmd =~ /^\|\|/;
+
+ # Trim off the pipe symbols and run the command now.
+ $cmd =~ s/^\|+\s*//;
+ redo PIPE;
+ };
+
+=head3 END OF COMMAND PARSING
+
+Anything left in C<$cmd> at this point is a Perl expression that we want to
+evaluate. We'll always evaluate in the user's context, and fully qualify
+any variables we might want to address in the C<DB> package.
+
+=cut
+
+ # t - turn trace on.
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
+ # s - single-step. Remember the last command was 's'.
+ $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do { $laststep = 's' };
+
+ # n - single-step, but not into subs. Remember last command
+ # was 'n'.
+ $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do { $laststep = 'n' };
+
+ } # PIPE:
+
+ # Make sure the flag that says "the debugger's running" is
+ # still on, to make sure we get control again.
+ $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
+
+ # Run *our* eval that executes in the caller's context.
+ &eval;
+
+ # Turn off the one-time-dump stuff now.
+ if ($onetimeDump) {
+ $onetimeDump = undef;
+ $onetimedumpDepth = undef;
+ }
+ elsif ( $term_pid == $$ ) {
+ eval { # May run under miniperl, when not available...
+ STDOUT->flush();
+ STDERR->flush();
+ };
+
+ # XXX If this is the master pid, print a newline.
+ print $OUT "\n";
+ }
+ } ## end while (($term || &setterm...
+
+=head3 POST-COMMAND PROCESSING
+
+After each command, we check to see if the command output was piped anywhere.
+If so, we go through the necessary code to unhook the pipe and go back to
+our standard filehandles for input and output.
+
+=cut
+
+ continue { # CMD:
+
+ # At the end of every command:
+ if ($piped) {
+
+ # Unhook the pipe mechanism now.
+ if ( $pager =~ /^\|/ ) {
+
+ # No error from the child.
+ $? = 0;
+
+ # we cannot warn here: the handle is missing --tchrist
+ close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+
+ # most of the $? crud was coping with broken cshisms
+ # $? is explicitly set to 0, so this never runs.
+ if ($?) {
+ print SAVEOUT "Pager `$pager' failed: ";
+ if ( $? == -1 ) {
+ print SAVEOUT "shell returned -1\n";
+ }
+ elsif ( $? >> 8 ) {
+ print SAVEOUT ( $? & 127 )
+ ? " (SIG#" . ( $? & 127 ) . ")"
+ : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
+ }
+ else {
+ print SAVEOUT "status ", ( $? >> 8 ), "\n";
+ }
+ } ## end if ($?)
+
+ # Reopen filehandle for our output (if we can) and
+ # restore STDOUT (if we can).
+ open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || &warn("Can't restore STDOUT");
+
+ # Turn off pipe exception handler if necessary.
+ $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Non-piped "pager". Just restore STDOUT.
+ open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
+ }
+
+ # Close filehandle pager was using, restore the normal one
+ # if necessary,
+ close(SAVEOUT);
+ select($selected), $selected = "" unless $selected eq "";
+
+ # No pipes now.
+ $piped = "";
+ } ## end if ($piped)
+ } # CMD:
+
+=head3 COMMAND LOOP TERMINATION
+
+When commands have finished executing, we come here. If the user closed the
+input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
+evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
+C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
+The interpreter will then execute the next line and then return control to us
+again.
+
+=cut
+
+ # No more commands? Quit.
+ $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
+
+ # Evaluate post-prompt commands.
+ foreach $evalarg (@$post) {
+ &eval;
+ }
+ } # if ($single || $signal)
+
+ # Put the user's globals back where you found them.
+ ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
+ ();
+} ## end sub DB
+
+# The following code may be executed now:
+# BEGIN {warn 4}
+
+=head2 sub
+
+C<sub> is called whenever a subroutine call happens in the program being
+debugged. The variable C<$DB::sub> contains the name of the subroutine
+being called.
+
+The core function of this subroutine is to actually call the sub in the proper
+context, capturing its output. This of course causes C<DB::DB> to get called
+again, repeating until the subroutine ends and returns control to C<DB::sub>
+again. Once control returns, C<DB::sub> figures out whether or not to dump the
+return value, and returns its captured copy of the return value as its own
+return value. The value then feeds back into the program being debugged as if
+C<DB::sub> hadn't been there at all.
+
+C<sub> does all the work of printing the subroutine entry and exit messages
+enabled by setting C<$frame>. It notes what sub the autoloader got called for,
+and also prints the return value if needed (for the C<r> command and if
+the 16 bit is set in C<$frame>).
+
+It also tracks the subroutine call depth by saving the current setting of
+C<$single> in the C<@stack> package global; if this exceeds the value in
+C<$deep>, C<sub> automatically turns on printing of the current depth by
+setting the C<4> bit in C<$single>. In any case, it keeps the current setting
+of stop/don't stop on entry to subs set as it currently is set.
+
+=head3 C<caller()> support
+
+If C<caller()> is called from the package C<DB>, it provides some
+additional data, in the following order:
+
+=over 4
+
+=item * C<$package>
+
+The package name the sub was in
+
+=item * C<$filename>
+
+The filename it was defined in
+
+=item * C<$line>
+
+The line number it was defined on
+
+=item * C<$subroutine>
+
+The subroutine name; C<(eval)> if an C<eval>().
+
+=item * C<$hasargs>
+
+1 if it has arguments, 0 if not
+
+=item * C<$wantarray>
+
+1 if array context, 0 if scalar context
+
+=item * C<$evaltext>
+
+The C<eval>() text, if any (undefined for C<eval BLOCK>)
+
+=item * C<$is_require>
+
+frame was created by a C<use> or C<require> statement
+
+=item * C<$hints>
+
+pragma information; subject to change between versions
+
+=item * C<$bitmask>
+
+pragma information; subject to change between versions
+
+=item * C<@DB::args>
+
+arguments with which the subroutine was invoked
+
+=back
+
+=cut
+
+sub sub {
+ # Do not use a regex in this subroutine -> results in corrupted memory
+ # See: [perl #66110]
+
+ # lock ourselves under threads
+ lock($DBGR);
+
+ # Whether or not the autoloader was running, a scalar to put the
+ # sub's return value in (if needed), and an array to put the sub's
+ # return value in (if needed).
+ my ( $al, $ret, @ret ) = "";
+ if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
+
+ # If the last ten characters are '::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ $al = " for $$sub" if defined $$sub;
+ }
+
+ # We stack the stack pointer and then increment it to protect us
+ # from a situation that might unwind a whole bunch of call frames
+ # at once. Localizing the stack pointer means that it will automatically
+ # unwind the same amount when multiple stack frames are unwound.
+ local $stack_depth = $stack_depth + 1; # Protect from non-local exits
+
+ # Expand @stack.
+ $#stack = $stack_depth;
+
+ # Save current single-step setting.
+ $stack[-1] = $single;
+
+ # Turn off all flags except single-stepping.
+ $single &= 1;
+
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+ (
+ $frame & 4 # Extended frame entry message
+ ? (
+ print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
+ )
+ : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
+
+ # standard frame entry message
+ )
+ if $frame;
+
+ # Determine the sub's return type,and capture approppriately.
+ if (wantarray) {
+
+ # Called in array context. call sub and capture output.
+ # DB::DB will recursively get control again if appropriate; we'll come
+ # back here when the sub is finished.
+ @ret = &$sub;
+
+ # Pop the single-step value back off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ # Check for exit trace messages...
+ (
+ $frame & 4 # Extended exit message
+ ? (
+ print_lineinfo( ' ' x $stack_depth, "out " ),
+ print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
+ )
+ : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
+
+ # Standard exit message
+ )
+ if $frame & 2;
+
+ # Print the return info if we need to.
+ if ( $doret eq $stack_depth or $frame & 16 ) {
+
+ # Turn off output record separator.
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+
+ # Indent if we're printing because of $frame tracing.
+ print $fh ' ' x $stack_depth if $frame & 16;
+
+ # Print the return value.
+ print $fh "list context return from $sub:\n";
+ dumpit( $fh, \@ret );
+
+ # And don't print it again.
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+ # And we have to return the return value now.
+ @ret;
+ } ## end if (wantarray)
+
+ # Scalar context.
+ else {
+ if ( defined wantarray ) {
+
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
+ }
+ else {
+
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
+ }
+
+ # Pop the single-step value off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ # If we're doing exit messages...
+ (
+ $frame & 4 # Extended messsages
+ ? (
+ print_lineinfo( ' ' x $stack_depth, "out " ),
+ print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
+ )
+ : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
+
+ # Standard messages
+ )
+ if $frame & 2;
+
+ # If we are supposed to show the return value... same as before.
+ if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+ print $fh ( ' ' x $stack_depth ) if $frame & 16;
+ print $fh (
+ defined wantarray
+ ? "scalar context return from $sub: "
+ : "void context return from $sub\n"
+ );
+ dumpit( $fh, $ret ) if defined wantarray;
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+
+ # Return the appropriate scalar value.
+ $ret;
+ } ## end else [ if (wantarray)
+} ## end sub sub
+
+sub lsub : lvalue {
+
+ # lock ourselves under threads
+ lock($DBGR);
+
+ # Whether or not the autoloader was running, a scalar to put the
+ # sub's return value in (if needed), and an array to put the sub's
+ # return value in (if needed).
+ my ( $al, $ret, @ret ) = "";
+ if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
+
+ # If the last ten characters are C'::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ $al = " for $$sub";
+ }
+
+ # We stack the stack pointer and then increment it to protect us
+ # from a situation that might unwind a whole bunch of call frames
+ # at once. Localizing the stack pointer means that it will automatically
+ # unwind the same amount when multiple stack frames are unwound.
+ local $stack_depth = $stack_depth + 1; # Protect from non-local exits
+
+ # Expand @stack.
+ $#stack = $stack_depth;
+
+ # Save current single-step setting.
+ $stack[-1] = $single;
+
+ # Turn off all flags except single-stepping.
+ $single &= 1;
+
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+ (
+ $frame & 4 # Extended frame entry message
+ ? (
+ print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
+ )
+ : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
+
+ # standard frame entry message
+ )
+ if $frame;
+
+ # Pop the single-step value back off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ # call the original lvalue sub.
+ &$sub;
+}
+
+=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
+
+In Perl 5.8.0, there was a major realignment of the commands and what they did,
+Most of the changes were to systematize the command structure and to eliminate
+commands that threw away user input without checking.
+
+The following sections describe the code added to make it easy to support
+multiple command sets with conflicting command names. This section is a start
+at unifying all command processing to make it simpler to develop commands.
+
+Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
+number, and C<$dbline> (the current line) as arguments.
+
+Support functions in this section which have multiple modes of failure C<die>
+on error; the rest simply return a false value.
+
+The user-interface functions (all of the C<cmd_*> functions) just output
+error messages.
+
+=head2 C<%set>
+
+The C<%set> hash defines the mapping from command letter to subroutine
+name suffix.
+
+C<%set> is a two-level hash, indexed by set name and then by command name.
+Note that trying to set the CommandSet to C<foobar> simply results in the
+5.8.0 command set being used, since there's no top-level entry for C<foobar>.
+
+=cut
+
+### The API section
+
+my %set = ( #
+ 'pre580' => {
+ 'a' => 'pre580_a',
+ 'A' => 'pre580_null',
+ 'b' => 'pre580_b',
+ 'B' => 'pre580_null',
+ 'd' => 'pre580_null',
+ 'D' => 'pre580_D',
+ 'h' => 'pre580_h',
+ 'M' => 'pre580_null',
+ 'O' => 'o',
+ 'o' => 'pre580_null',
+ 'v' => 'M',
+ 'w' => 'v',
+ 'W' => 'pre580_W',
+ },
+ 'pre590' => {
+ '<' => 'pre590_prepost',
+ '<<' => 'pre590_prepost',
+ '>' => 'pre590_prepost',
+ '>>' => 'pre590_prepost',
+ '{' => 'pre590_prepost',
+ '{{' => 'pre590_prepost',
+ },
+);
+
+=head2 C<cmd_wrapper()> (API)
+
+C<cmd_wrapper()> allows the debugger to switch command sets
+depending on the value of the C<CommandSet> option.
+
+It tries to look up the command in the C<%set> package-level I<lexical>
+(which means external entities can't fiddle with it) and create the name of
+the sub to call based on the value found in the hash (if it's there). I<All>
+of the commands to be handled in a set have to be added to C<%set>; if they
+aren't found, the 5.8.0 equivalent is called (if there is one).
+
+This code uses symbolic references.
+
+=cut
+
+sub cmd_wrapper {
+ my $cmd = shift;
+ my $line = shift;
+ my $dblineno = shift;
+
+ # Assemble the command subroutine's name by looking up the
+ # command set and command name in %set. If we can't find it,
+ # default to the older version of the command.
+ my $call = 'cmd_'
+ . ( $set{$CommandSet}{$cmd}
+ || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) );
+
+ # Call the command subroutine, call it by name.
+ return &$call( $cmd, $line, $dblineno );
+} ## end sub cmd_wrapper
+
+=head3 C<cmd_a> (command)
+
+The C<a> command handles pre-execution actions. These are associated with a
+particular line, so they're stored in C<%dbline>. We default to the current
+line if none is specified.
+
+=cut
+
+sub cmd_a {
+ my $cmd = shift;
+ my $line = shift || ''; # [.|line] expr
+ my $dbline = shift;
+
+ # If it's dot (here), or not all digits, use the current line.
+ $line =~ s/^(\.|(?:[^\d]))/$dbline/;
+
+ # Should be a line number followed by an expression.
+ if ( $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
+ my ( $lineno, $expr ) = ( $1, $2 );
+
+ # If we have an expression ...
+ if ( length $expr ) {
+
+ # ... but the line isn't breakable, complain.
+ if ( $dbline[$lineno] == 0 ) {
+ print $OUT
+ "Line $lineno($dbline[$lineno]) does not have an action?\n";
+ }
+ else {
+
+ # It's executable. Record that the line has an action.
+ $had_breakpoints{$filename} |= 2;
+
+ # Remove any action, temp breakpoint, etc.
+ $dbline{$lineno} =~ s/\0[^\0]*//;
+
+ # Add the action to the line.
+ $dbline{$lineno} .= "\0" . action($expr);
+ }
+ } ## end if (length $expr)
+ } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
+ else {
+
+ # Syntax wrong.
+ print $OUT
+ "Adding an action requires an optional lineno and an expression\n"
+ ; # hint
+ }
+} ## end sub cmd_a
+
+=head3 C<cmd_A> (command)
+
+Delete actions. Similar to above, except the delete code is in a separate
+subroutine, C<delete_action>.
+
+=cut
+
+sub cmd_A {
+ my $cmd = shift;
+ my $line = shift || '';
+ my $dbline = shift;
+
+ # Dot is this line.
+ $line =~ s/^\./$dbline/;
+
+ # Call delete_action with a null param to delete them all.
+ # The '1' forces the eval to be true. It'll be false only
+ # if delete_action blows up for some reason, in which case
+ # we print $@ and get out.
+ if ( $line eq '*' ) {
+ eval { &delete_action(); 1 } or print $OUT $@ and return;
+ }
+
+ # There's a real line number. Pass it to delete_action.
+ # Error trapping is as above.
+ elsif ( $line =~ /^(\S.*)/ ) {
+ eval { &delete_action($1); 1 } or print $OUT $@ and return;
+ }
+
+ # Swing and a miss. Bad syntax.
+ else {
+ print $OUT
+ "Deleting an action requires a line number, or '*' for all\n" ; # hint
+ }
+} ## end sub cmd_A
+
+=head3 C<delete_action> (API)
+
+C<delete_action> accepts either a line number or C<undef>. If a line number
+is specified, we check for the line being executable (if it's not, it
+couldn't have had an action). If it is, we just take the action off (this
+will get any kind of an action, including breakpoints).
+
+=cut
+
+sub delete_action {
+ my $i = shift;
+ if ( defined($i) ) {
+
+ # Can there be one?
+ die "Line $i has no action .\n" if $dbline[$i] == 0;
+
+ # Nuke whatever's there.
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ else {
+ print $OUT "Deleting all actions...\n";
+ for my $file ( keys %had_breakpoints ) {
+ local *dbline = $main::{ '_<' . $file };
+ my $max = $#dbline;
+ my $was;
+ for ( $i = 1 ; $i <= $max ; $i++ ) {
+ if ( defined $dbline{$i} ) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ unless ( $had_breakpoints{$file} &= ~2 ) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for ($i = 1 ; $i <= $max...
+ } ## end for my $file (keys %had_breakpoints)
+ } ## end else [ if (defined($i))
+} ## end sub delete_action
+
+=head3 C<cmd_b> (command)
+
+Set breakpoints. Since breakpoints can be set in so many places, in so many
+ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
+we try to parse the command type, and then shuttle it off to an appropriate
+subroutine to actually do the work of setting the breakpoint in the right
+place.
+
+=cut
+
+sub cmd_b {
+ my $cmd = shift;
+ my $line = shift; # [.|line] [cond]
+ my $dbline = shift;
+
+ # Make . the current line number if it's there..
+ $line =~ s/^\./$dbline/;
+
+ # No line number, no condition. Simple break on current line.
+ if ( $line =~ /^\s*$/ ) {
+ &cmd_b_line( $dbline, 1 );
+ }
+
+ # Break on load for a file.
+ elsif ( $line =~ /^load\b\s*(.*)/ ) {
+ my $file = $1;
+ $file =~ s/\s+$//;
+ &cmd_b_load($file);
+ }
+
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ( $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
+
+ # Capture the condition if there is one. Make it true if none.
+ my $cond = length $3 ? $3 : '1';
+
+ # Save the sub name and set $break to 1 if $1 was 'postpone', 0
+ # if it was 'compile'.
+ my ( $subname, $break ) = ( $2, $1 eq 'postpone' );
+
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/\'/::/g;
+
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${'package'}::" . $subname unless $subname =~ /::/;
+
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ # Save the break type for this sub.
+ $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ } ## end elsif ($line =~ ...
+
+ # b <sub name> [<condition>]
+ elsif ( $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+
+ #
+ $subname = $1;
+ $cond = length $2 ? $2 : '1';
+ &cmd_b_sub( $subname, $cond );
+ }
+
+ # b <line> [<condition>].
+ elsif ( $line =~ /^(\d*)\s*(.*)/ ) {
+
+ # Capture the line. If none, it's the current line.
+ $line = $1 || $dbline;
+
+ # If there's no condition, make it '1'.
+ $cond = length $2 ? $2 : '1';
+
+ # Break on line.
+ &cmd_b_line( $line, $cond );
+ }
+
+ # Line didn't make sense.
+ else {
+ print "confused by line($line)?\n";
+ }
+} ## end sub cmd_b
+
+=head3 C<break_on_load> (API)
+
+We want to break when this file is loaded. Mark this file in the
+C<%break_on_load> hash, and note that it has a breakpoint in
+C<%had_breakpoints>.
+
+=cut
+
+sub break_on_load {
+ my $file = shift;
+ $break_on_load{$file} = 1;
+ $had_breakpoints{$file} |= 1;
+}
+
+=head3 C<report_break_on_load> (API)
+
+Gives us an array of filenames that are set to break on load. Note that
+only files with break-on-load are in here, so simply showing the keys
+suffices.
+
+=cut
+
+sub report_break_on_load {
+ sort keys %break_on_load;
+}
+
+=head3 C<cmd_b_load> (command)
+
+We take the file passed in and try to find it in C<%INC> (which maps modules
+to files they came from). We mark those files for break-on-load via
+C<break_on_load> and then report that it was done.
+
+=cut
+
+sub cmd_b_load {
+ my $file = shift;
+ my @files;
+
+ # This is a block because that way we can use a redo inside it
+ # even without there being any looping structure at all outside it.
+ {
+
+ # Save short name and full path if found.
+ push @files, $file;
+ push @files, $::INC{$file} if $::INC{$file};
+
+ # Tack on .pm and do it again unless there was a '.' in the name
+ # already.
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
+
+ # Do the real work here.
+ break_on_load($_) for @files;
+
+ # All the files that have break-on-load breakpoints.
+ @files = report_break_on_load;
+
+ # Normalize for the purposes of our printing this.
+ local $\ = '';
+ local $" = ' ';
+ print $OUT "Will stop on load of `@files'.\n";
+} ## end sub cmd_b_load
+
+=head3 C<$filename_error> (API package global)
+
+Several of the functions we need to implement in the API need to work both
+on the current file and on other files. We don't want to duplicate code, so
+C<$filename_error> is used to contain the name of the file that's being
+worked on (if it's not the current one).
+
+We can now build functions in pairs: the basic function works on the current
+file, and uses C<$filename_error> as part of its error message. Since this is
+initialized to C<"">, no filename will appear when we are working on the
+current file.
+
+The second function is a wrapper which does the following:
+
+=over 4
+
+=item *
+
+Localizes C<$filename_error> and sets it to the name of the file to be processed.
+
+=item *
+
+Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
+
+=item *
+
+Calls the first function.
+
+The first function works on the I<current> file (i.e., the one we changed to),
+and prints C<$filename_error> in the error message (the name of the other file)
+if it needs to. When the functions return, C<*dbline> is restored to point
+to the actual current file (the one we're executing in) and
+C<$filename_error> is restored to C<"">. This restores everything to
+the way it was before the second function was called at all.
+
+See the comments in C<breakable_line> and C<breakable_line_in_file> for more
+details.
+
+=back
+
+=cut
+
+$filename_error = '';
+
+=head3 breakable_line(from, to) (API)
+
+The subroutine decides whether or not a line in the current file is breakable.
+It walks through C<@dbline> within the range of lines specified, looking for
+the first line that is breakable.
+
+If C<$to> is greater than C<$from>, the search moves forwards, finding the
+first line I<after> C<$to> that's breakable, if there is one.
+
+If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
+first line I<before> C<$to> that's breakable, if there is one.
+
+=cut
+
+sub breakable_line {
+
+ my ( $from, $to ) = @_;
+
+ # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
+ my $i = $from;
+
+ # If there are at least 2 arguments, we're trying to search a range.
+ if ( @_ >= 2 ) {
+
+ # $delta is positive for a forward search, negative for a backward one.
+ my $delta = $from < $to ? +1 : -1;
+
+ # Keep us from running off the ends of the file.
+ my $limit = $delta > 0 ? $#dbline : 1;
+
+ # Clever test. If you're a mathematician, it's obvious why this
+ # test works. If not:
+ # If $delta is positive (going forward), $limit will be $#dbline.
+ # If $to is less than $limit, ($limit - $to) will be positive, times
+ # $delta of 1 (positive), so the result is > 0 and we should use $to
+ # as the stopping point.
+ #
+ # If $to is greater than $limit, ($limit - $to) is negative,
+ # times $delta of 1 (positive), so the result is < 0 and we should
+ # use $limit ($#dbline) as the stopping point.
+ #
+ # If $delta is negative (going backward), $limit will be 1.
+ # If $to is zero, ($limit - $to) will be 1, times $delta of -1
+ # (negative) so the result is > 0, and we use $to as the stopping
+ # point.
+ #
+ # If $to is less than zero, ($limit - $to) will be positive,
+ # times $delta of -1 (negative), so the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # If $to is 1, ($limit - $to) will zero, times $delta of -1
+ # (negative), still giving zero; the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # if $to is >1, ($limit - $to) will be negative, times $delta of -1
+ # (negative), giving a positive (>0) value, so we'll set $limit to
+ # $to.
+
+ $limit = $to if ( $limit - $to ) * $delta > 0;
+
+ # The real search loop.
+ # $i starts at $from (the point we want to start searching from).
+ # We move through @dbline in the appropriate direction (determined
+ # by $delta: either -1 (back) or +1 (ahead).
+ # We stay in as long as we haven't hit an executable line
+ # ($dbline[$i] == 0 means not executable) and we haven't reached
+ # the limit yet (test similar to the above).
+ $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0;
+
+ } ## end if (@_ >= 2)
+
+ # If $i points to a line that is executable, return that.
+ return $i unless $dbline[$i] == 0;
+
+ # Format the message and print it: no breakable lines in range.
+ my ( $pl, $upto ) = ( '', '' );
+ ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to;
+
+ # If there's a filename in filename_error, we'll see it.
+ # If not, not.
+ die "Line$pl $from$upto$filename_error not breakable\n";
+} ## end sub breakable_line
+
+=head3 breakable_line_in_filename(file, from, to) (API)
+
+Like C<breakable_line>, but look in another file.
+
+=cut
+
+sub breakable_line_in_filename {
+
+ # Capture the file name.
+ my ($f) = shift;
+
+ # Swap the magic line array over there temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # If there's an error, it's in this other file.
+ local $filename_error = " of `$f'";
+
+ # Find the breakable line.
+ breakable_line(@_);
+
+ # *dbline and $filename_error get restored when this block ends.
+
+} ## end sub breakable_line_in_filename
+
+=head3 break_on_line(lineno, [condition]) (API)
+
+Adds a breakpoint with the specified condition (or 1 if no condition was
+specified) to the specified line. Dies if it can't.
+
+=cut
+
+sub break_on_line {
+ my ( $i, $cond ) = @_;
+
+ # Always true if no condition supplied.
+ $cond = 1 unless @_ >= 2;
+
+ my $inii = $i;
+ my $after = '';
+ my $pl = '';
+
+ # Woops, not a breakable line. $filename_error allows us to say
+ # if it was in a different file.
+ die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
+
+ # Mark this file as having breakpoints in it.
+ $had_breakpoints{$filename} |= 1;
+
+ # If there is an action or condition here already ...
+ if ( $dbline{$i} ) {
+
+ # ... swap this condition for the existing one.
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ else {
+
+ # Nothing here - just add the condition.
+ $dbline{$i} = $cond;
+ }
+} ## end sub break_on_line
+
+=head3 cmd_b_line(line, [condition]) (command)
+
+Wrapper for C<break_on_line>. Prints the failure message if it
+doesn't work.
+
+=cut
+
+sub cmd_b_line {
+ eval { break_on_line(@_); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ };
+} ## end sub cmd_b_line
+
+=head3 break_on_filename_line(file, line, [condition]) (API)
+
+Switches to the file specified and then calls C<break_on_line> to set
+the breakpoint.
+
+=cut
+
+sub break_on_filename_line {
+ my ( $f, $i, $cond ) = @_;
+
+ # Always true if condition left off.
+ $cond = 1 unless @_ >= 3;
+
+ # Switch the magical hash temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # Localize the variables that break_on_line uses to make its message.
+ local $filename_error = " of `$f'";
+ local $filename = $f;
+
+ # Add the breakpoint.
+ break_on_line( $i, $cond );
+} ## end sub break_on_filename_line
+
+=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
+
+Switch to another file, search the range of lines specified for an
+executable one, and put a breakpoint on the first one you find.
+
+=cut
+
+sub break_on_filename_line_range {
+ my ( $f, $from, $to, $cond ) = @_;
+
+ # Find a breakable line if there is one.
+ my $i = breakable_line_in_filename( $f, $from, $to );
+
+ # Always true if missing.
+ $cond = 1 unless @_ >= 3;
+
+ # Add the breakpoint.
+ break_on_filename_line( $f, $i, $cond );
+} ## end sub break_on_filename_line_range
+
+=head3 subroutine_filename_lines(subname, [condition]) (API)
+
+Search for a subroutine within a given file. The condition is ignored.
+Uses C<find_sub> to locate the desired subroutine.
+
+=cut
+
+sub subroutine_filename_lines {
+ my ( $subname, $cond ) = @_;
+
+ # Returned value from find_sub() is fullpathname:startline-endline.
+ # The match creates the list (fullpathname, start, end). Falling off
+ # the end of the subroutine returns this implicitly.
+ find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
+} ## end sub subroutine_filename_lines
+
+=head3 break_subroutine(subname) (API)
+
+Places a break on the first line possible in the specified subroutine. Uses
+C<subroutine_filename_lines> to find the subroutine, and
+C<break_on_filename_line_range> to place the break.
+
+=cut
+
+sub break_subroutine {
+ my $subname = shift;
+
+ # Get filename, start, and end.
+ my ( $file, $s, $e ) = subroutine_filename_lines($subname)
+ or die "Subroutine $subname not found.\n";
+
+ # Null condition changes to '1' (always true).
+ $cond = 1 unless @_ >= 2;
+
+ # Put a break the first place possible in the range of lines
+ # that make up this subroutine.
+ break_on_filename_line_range( $file, $s, $e, @_ );
+} ## end sub break_subroutine
+
+=head3 cmd_b_sub(subname, [condition]) (command)
+
+We take the incoming subroutine name and fully-qualify it as best we can.
+
+=over 4
+
+=item 1. If it's already fully-qualified, leave it alone.
+
+=item 2. Try putting it in the current package.
+
+=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
+
+=item 4. If it starts with '::', put it in 'main::'.
+
+=back
+
+After all this cleanup, we call C<break_subroutine> to try to set the
+breakpoint.
+
+=cut
+
+sub cmd_b_sub {
+ my ( $subname, $cond ) = @_;
+
+ # Add always-true condition if we have none.
+ $cond = 1 unless @_ >= 2;
+
+ # If the subname isn't a code reference, qualify it so that
+ # break_subroutine() will work right.
+ unless ( ref $subname eq 'CODE' ) {
+
+ # Not Perl4.
+ $subname =~ s/\'/::/g;
+ my $s = $subname;
+
+ # Put it in this package unless it's already qualified.
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+
+ # Requalify it into CORE::GLOBAL if qualifying it into this
+ # package resulted in its not being defined, but only do so
+ # if it really is in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
+
+ # Put it in package 'main' if it has a leading ::.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ } ## end unless (ref $subname eq 'CODE')
+
+ # Try to set the breakpoint.
+ eval { break_subroutine( $subname, $cond ); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
+} ## end sub cmd_b_sub
+
+=head3 C<cmd_B> - delete breakpoint(s) (command)
+
+The command mostly parses the command line and tries to turn the argument
+into a line spec. If it can't, it uses the current line. It then calls
+C<delete_breakpoint> to actually do the work.
+
+If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
+thereby deleting all the breakpoints.
+
+=cut
+
+sub cmd_B {
+ my $cmd = shift;
+
+ # No line spec? Use dbline.
+ # If there is one, use it if it's non-zero, or wipe it out if it is.
+ my $line = ( $_[0] =~ /^\./ ) ? $dbline : shift || '';
+ my $dbline = shift;
+
+ # If the line was dot, make the line the current one.
+ $line =~ s/^\./$dbline/;
+
+ # If it's * we're deleting all the breakpoints.
+ if ( $line eq '*' ) {
+ eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
+ }
+
+ # If there is a line spec, delete the breakpoint on that line.
+ elsif ( $line =~ /^(\S.*)/ ) {
+ eval { &delete_breakpoint( $line || $dbline ); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ };
+ } ## end elsif ($line =~ /^(\S.*)/)
+
+ # No line spec.
+ else {
+ print $OUT
+ "Deleting a breakpoint requires a line number, or '*' for all\n"
+ ; # hint
+ }
+} ## end sub cmd_B
+
+=head3 delete_breakpoint([line]) (API)
+
+This actually does the work of deleting either a single breakpoint, or all
+of them.
+
+For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
+just drop out with a message saying so. If it is, we remove the condition
+part of the 'condition\0action' that says there's a breakpoint here. If,
+after we've done that, there's nothing left, we delete the corresponding
+line in C<%dbline> to signal that no action needs to be taken for this line.
+
+For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
+which lists all currently-loaded files which have breakpoints. We then look
+at each line in each of these files, temporarily switching the C<%dbline>
+and C<@dbline> structures to point to the files in question, and do what
+we did in the single line case: delete the condition in C<@dbline>, and
+delete the key in C<%dbline> if nothing's left.
+
+We then wholesale delete C<%postponed>, C<%postponed_file>, and
+C<%break_on_load>, because these structures contain breakpoints for files
+and code that haven't been loaded yet. We can just kill these off because there
+are no magical debugger structures associated with them.
+
+=cut
+
+sub delete_breakpoint {
+ my $i = shift;
+
+ # If we got a line, delete just that one.
+ if ( defined($i) ) {
+
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
+
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/^[^\0]*//;
+
+ # Remove the entry entirely if there's no action left.
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+
+ # No line; delete them all.
+ else {
+ print $OUT "Deleting all breakpoints...\n";
+
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $file ( keys %had_breakpoints ) {
+
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ my $max = $#dbline;
+ my $was;
+
+ # For all lines in this file ...
+ for ( $i = 1 ; $i <= $max ; $i++ ) {
+
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
+
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ( $dbline{$i} =~ s/^\0?$// ) {
+
+ # Remove the entry altogether if no action is there.
+ delete $dbline{$i};
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for ($i = 1 ; $i <= $max...
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$file} &= ~1 ) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for my $file (keys %had_breakpoints)
+
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ } ## end else [ if (defined($i))
+} ## end sub delete_breakpoint
+
+=head3 cmd_stop (command)
+
+This is meant to be part of the new command API, but it isn't called or used
+anywhere else in the debugger. XXX It is probably meant for use in development
+of new commands.
+
+=cut
+
+sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
+}
+
+=head3 C<cmd_e> - threads
+
+Display the current thread id:
+
+ e
+
+This could be how (when implemented) to send commands to this thread id (e cmd)
+or that thread id (e tid cmd).
+
+=cut
+
+sub cmd_e {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread id: $tid\n";
+ }
+} ## end sub cmd_e
+
+=head3 C<cmd_E> - list of thread ids
+
+Display the list of available thread ids:
+
+ E
+
+This could be used (when implemented) to send commands to all threads (E cmd).
+
+=cut
+
+sub cmd_E {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread ids: ".join(', ',
+ map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
+ )."\n";
+ }
+} ## end sub cmd_E
+
+=head3 C<cmd_h> - help command (command)
+
+Does the work of either
+
+=over 4
+
+=item *
+
+Showing all the debugger help
+
+=item *
+
+Showing help for a specific command
+
+=back
+
+=cut
+
+sub cmd_h {
+ my $cmd = shift;
+
+ # If we have no operand, assume null.
+ my $line = shift || '';
+
+ # 'h h'. Print the long-format help.
+ if ( $line =~ /^h\s*/ ) {
+ print_help($help);
+ }
+
+ # 'h <something>'. Search for the command and print only its help.
+ elsif ( $line =~ /^(\S.*)$/ ) {
+
+ # support long commands; otherwise bogus errors
+ # happen when you ask for h on <CR> for example
+ my $asked = $1; # the command requested
+ # (for proper error message)
+
+ my $qasked = quotemeta($asked); # for searching; we don't
+ # want to use it as a pattern.
+ # XXX: finds CR but not <CR>
+
+ # Search the help string for the command.
+ if (
+ $help =~ /^ # Start of a line
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The requested command
+ /mx
+ )
+ {
+
+ # It's there; pull it out and print it.
+ while (
+ $help =~ /^
+ (<? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command
+ ([\s\S]*?) # Description line(s)
+ \n) # End of last description line
+ (?!\s) # Next line not starting with
+ # whitespace
+ /mgx
+ )
+ {
+ print_help($1);
+ }
+ }
+
+ # Not found; not a debugger command.
+ else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } ## end elsif ($line =~ /^(\S.*)$/)
+
+ # 'h' - print the summary help.
+ else {
+ print_help($summary);
+ }
+} ## end sub cmd_h
+
+=head3 C<cmd_i> - inheritance display
+
+Display the (nested) parentage of the module or object given.
+
+=cut
+
+sub cmd_i {
+ my $cmd = shift;
+ my $line = shift;
+ foreach my $isa ( split( /\s+/, $line ) ) {
+ $evalarg = $isa;
+ ($isa) = &eval;
+ no strict 'refs';
+ print join(
+ ', ',
+ map {
+ "$_"
+ . (
+ defined( ${"$_\::VERSION"} )
+ ? ' ' . ${"$_\::VERSION"}
+ : undef )
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
+ );
+ print "\n";
+ }
+} ## end sub cmd_i
+
+=head3 C<cmd_l> - list lines (command)
+
+Most of the command is taken up with transforming all the different line
+specification syntaxes into 'start-stop'. After that is done, the command
+runs a loop over C<@dbline> for the specified range of lines. It handles
+the printing of each line and any markers (C<==E<gt>> for current line,
+C<b> for break on this line, C<a> for action on this line, C<:> for this
+line breakable).
+
+We save the last line listed in the C<$start> global for further listing
+later.
+
+=cut
+
+sub cmd_l {
+ my $current_line = $line;
+ my $cmd = shift;
+ my $line = shift;
+
+ # If this is '-something', delete any spaces after the dash.
+ $line =~ s/^-\s*$/-/;
+
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ if ( $line =~ /^(\$.*)/s ) {
+
+ # Set up for DB::eval() - evaluate in *user* context.
+ $evalarg = $1;
+ # $evalarg = $2;
+ my ($s) = &eval;
+
+ # Ooops. Bad scalar.
+ print( $OUT "Error: $@\n" ), next CMD if $@;
+
+ # Good scalar. If it's a reference, find what it points to.
+ $s = CvGV_name($s);
+ print( $OUT "Interpreted as: $1 $s\n" );
+ $line = "$1 $s";
+
+ # Call self recursively to really do the command.
+ &cmd_l( 'l', $s );
+ } ## end if ($line =~ /^(\$.*)/s)
+
+ # l name. Try to find a sub by that name.
+ elsif ( $line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s ) {
+ my $s = $subname = $1;
+
+ # De-Perl4.
+ $subname =~ s/\'/::/;
+
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
+
+ # Put it in CORE::GLOBAL if t doesn't start with :: and
+ # it doesn't live in this package and it lives in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
+
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+
+ # Pull off start-stop.
+ $subrange = pop @pieces;
+
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
+
+ # If we're not in that file, switch over to it.
+ if ( $file ne $filename ) {
+ print $OUT "Switching to file '$file'.\n"
+ unless $slave_editor;
+
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
+
+ # Subrange is 'start-stop'. If this is less than a window full,
+ # swap it to 'start+', which will list a window from the start point.
+ if ($subrange) {
+ if ( eval($subrange) < -$window ) {
+ $subrange =~ s/-.*/+/;
+ }
+
+ # Call self recursively to list the range.
+ $line = $subrange;
+ &cmd_l( 'l', $subrange );
+ } ## end if ($subrange)
+
+ # Couldn't find it.
+ else {
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
+
+ # Bare 'l' command.
+ elsif ( $line =~ /^\s*$/ ) {
+
+ # Compute new range to list.
+ $incr = $window - 1;
+ $line = $start . '-' . ( $start + $incr );
+
+ # Recurse to do it.
+ &cmd_l( 'l', $line );
+ }
+
+ # l [start]+number_of_lines
+ elsif ( $line =~ /^(\d*)\+(\d*)$/ ) {
+
+ # Don't reset start for 'l +nnn'.
+ $start = $1 if $1;
+
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+
+ # Create a line range we'll understand, and recurse to do it.
+ $line = $start . '-' . ( $start + $incr );
+ &cmd_l( 'l', $line );
+ } ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
+
+ # l start-stop or l start,stop
+ elsif ( $line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ ) {
+
+ # Determine end point; use end of file if not specified.
+ $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
+
+ # Go on to the end, and then stop.
+ $end = $max if $end > $max;
+
+ # Determine start line.
+ $i = $2;
+ $i = $line if $i eq '.';
+ $i = 1 if $i < 1;
+ $incr = $end - $i;
+
+ # If we're running under a slave editor, force it to show the lines.
+ if ($slave_editor) {
+ print $OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ }
+
+ # We're doing it ourselves. We want to show the line and special
+ # markers for:
+ # - the current line in execution
+ # - whether a line is breakable or not
+ # - whether a line has a break or not
+ # - whether a line has an action or not
+ else {
+ for ( ; $i <= $end ; $i++ ) {
+
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ ( $stop, $action ) = split( /\0/, $dbline{$i} )
+ if $dbline{$i};
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ $arrow =
+ ( $i == $current_line and $filename eq $filename_ini )
+ ? '==>'
+ : ( $dbline[$i] + 0 ? ':' : ' ' );
+
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+
+ # Print the line.
+ print $OUT "$i$arrow\t", $dbline[$i];
+
+ # Move on to the next line. Drop out on an interrupt.
+ $i++, last if $signal;
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ print $OUT "\n" unless $dbline[ $i - 1 ] =~ /\n$/;
+ } ## end else [ if ($slave_editor)
+
+ # Save the point we last listed to in case another relative 'l'
+ # command is desired. Don't let it run off the end.
+ $start = $i;
+ $start = $max if $start > $max;
+ } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
+} ## end sub cmd_l
+
+=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
+
+To list breakpoints, the command has to look determine where all of them are
+first. It starts a C<%had_breakpoints>, which tells us what all files have
+breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
+magic source and breakpoint data structures) to the file, and then look
+through C<%dbline> for lines with breakpoints and/or actions, listing them
+out. We look through C<%postponed> not-yet-compiled subroutines that have
+breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
+that have breakpoints.
+
+Watchpoints are simpler: we just list the entries in C<@to_watch>.
+
+=cut
+
+sub cmd_L {
+ my $cmd = shift;
+
+ # If no argument, list everything. Pre-5.8.0 version always lists
+ # everything
+ my $arg = shift || 'abw';
+ $arg = 'abw' unless $CommandSet eq '580'; # sigh...
+
+ # See what is wanted.
+ my $action_wanted = ( $arg =~ /a/ ) ? 1 : 0;
+ my $break_wanted = ( $arg =~ /b/ ) ? 1 : 0;
+ my $watch_wanted = ( $arg =~ /w/ ) ? 1 : 0;
+
+ # Breaks and actions are found together, so we look in the same place
+ # for both.
+ if ( $break_wanted or $action_wanted ) {
+
+ # Look in all the files with breakpoints...
+ for my $file ( keys %had_breakpoints ) {
+
+ # Temporary switch to this file.
+ local *dbline = $main::{ '_<' . $file };
+
+ # Set up to look through the whole file.
+ my $max = $#dbline;
+ my $was; # Flag: did we print something
+ # in this file?
+
+ # For each line in the file ...
+ for ( $i = 1 ; $i <= $max ; $i++ ) {
+
+ # We've got something on this line.
+ if ( defined $dbline{$i} ) {
+
+ # Print the header if we haven't.
+ print $OUT "$file:\n" unless $was++;
+
+ # Print the line.
+ print $OUT " $i:\t", $dbline[$i];
+
+ # Pull out the condition and the action.
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+
+ # Print the break if there is one and it's wanted.
+ print $OUT " break if (", $stop, ")\n"
+ if $stop
+ and $break_wanted;
+
+ # Print the action if there is one and it's wanted.
+ print $OUT " action: ", $action, "\n"
+ if $action
+ and $action_wanted;
+
+ # Quit if the user hit interrupt.
+ last if $signal;
+ } ## end if (defined $dbline{$i...
+ } ## end for ($i = 1 ; $i <= $max...
+ } ## end for my $file (keys %had_breakpoints)
+ } ## end if ($break_wanted or $action_wanted)
+
+ # Look for breaks in not-yet-compiled subs:
+ if ( %postponed and $break_wanted ) {
+ print $OUT "Postponed breakpoints in subroutines:\n";
+ my $subname;
+ for $subname ( keys %postponed ) {
+ print $OUT " $subname\t$postponed{$subname}\n";
+ last if $signal;
+ }
+ } ## end if (%postponed and $break_wanted)
+
+ # Find files that have not-yet-loaded breaks:
+ my @have = map { # Combined keys
+ keys %{ $postponed_file{$_} }
+ } keys %postponed_file;
+
+ # If there are any, list them.
+ if ( @have and ( $break_wanted or $action_wanted ) ) {
+ print $OUT "Postponed breakpoints in files:\n";
+ my ( $file, $line );
+
+ for $file ( keys %postponed_file ) {
+ my $db = $postponed_file{$file};
+ print $OUT " $file:\n";
+ for $line ( sort { $a <=> $b } keys %$db ) {
+ print $OUT " $line:\n";
+ my ( $stop, $action ) = split( /\0/, $$db{$line} );
+ print $OUT " break if (", $stop, ")\n"
+ if $stop
+ and $break_wanted;
+ print $OUT " action: ", $action, "\n"
+ if $action
+ and $action_wanted;
+ last if $signal;
+ } ## end for $line (sort { $a <=>...
+ last if $signal;
+ } ## end for $file (keys %postponed_file)
+ } ## end if (@have and ($break_wanted...
+ if ( %break_on_load and $break_wanted ) {
+ print $OUT "Breakpoints on load:\n";
+ my $file;
+ for $file ( keys %break_on_load ) {
+ print $OUT " $file\n";
+ last if $signal;
+ }
+ } ## end if (%break_on_load and...
+ if ($watch_wanted) {
+ if ( $trace & 2 ) {
+ print $OUT "Watch-expressions:\n" if @to_watch;
+ for my $expr (@to_watch) {
+ print $OUT " $expr\n";
+ last if $signal;
+ }
+ } ## end if ($trace & 2)
+ } ## end if ($watch_wanted)
+} ## end sub cmd_L
+
+=head3 C<cmd_M> - list modules (command)
+
+Just call C<list_modules>.
+
+=cut
+
+sub cmd_M {
+ &list_modules();
+}
+
+=head3 C<cmd_o> - options (command)
+
+If this is just C<o> by itself, we list the current settings via
+C<dump_option>. If there's a nonblank value following it, we pass that on to
+C<parse_options> for processing.
+
+=cut
+
+sub cmd_o {
+ my $cmd = shift;
+ my $opt = shift || ''; # opt[=val]
+
+ # Nonblank. Try to parse and process.
+ if ( $opt =~ /^(\S.*)/ ) {
+ &parse_options($1);
+ }
+
+ # Blank. List the current option settings.
+ else {
+ for (@options) {
+ &dump_option($_);
+ }
+ }
+} ## end sub cmd_o
+
+=head3 C<cmd_O> - nonexistent in 5.8.x (command)
+
+Advises the user that the O command has been renamed.
+
+=cut
+
+sub cmd_O {
+ print $OUT "The old O command is now the o command.\n"; # hint
+ print $OUT "Use 'h' to get current command help synopsis or\n"; #
+ print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
+}
+
+=head3 C<cmd_v> - view window (command)
+
+Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to
+move back a few lines to list the selected line in context. Uses C<cmd_l>
+to do the actual listing after figuring out the range of line to request.
+
+=cut
+
+sub cmd_v {
+ my $cmd = shift;
+ my $line = shift;
+
+ # Extract the line to list around. (Astute readers will have noted that
+ # this pattern will match whether or not a numeric line is specified,
+ # which means that we'll always enter this loop (though a non-numeric
+ # argument results in no action at all)).
+ if ( $line =~ /^(\d*)$/ ) {
+
+ # Total number of lines to list (a windowful).
+ $incr = $window - 1;
+
+ # Set the start to the argument given (if there was one).
+ $start = $1 if $1;
+
+ # Back up by the context amount.
+ $start -= $preview;
+
+ # Put together a linespec that cmd_l will like.
+ $line = $start . '-' . ( $start + $incr );
+
+ # List the lines.
+ &cmd_l( 'l', $line );
+ } ## end if ($line =~ /^(\d*)$/)
+} ## end sub cmd_v
+
+=head3 C<cmd_w> - add a watch expression (command)
+
+The 5.8 version of this command adds a watch expression if one is specified;
+it does nothing if entered with no operands.
+
+We extract the expression, save it, evaluate it in the user's context, and
+save the value. We'll re-evaluate it each time the debugger passes a line,
+and will stop (see the code at the top of the command loop) if the value
+of any of the expressions changes.
+
+=cut
+
+sub cmd_w {
+ my $cmd = shift;
+
+ # Null expression if no arguments.
+ my $expr = shift || '';
+
+ # If expression is not null ...
+ if ( $expr =~ /^(\S.*)/ ) {
+
+ # ... save it.
+ push @to_watch, $expr;
+
+ # Parameterize DB::eval and call it to get the expression's value
+ # in the user's context. This version can handle expressions which
+ # return a list value.
+ $evalarg = $expr;
+ my ($val) = join( ' ', &eval );
+ $val = ( defined $val ) ? "'$val'" : 'undef';
+
+ # Save the current value of the expression.
+ push @old_watch, $val;
+
+ # We are now watching expressions.
+ $trace |= 2;
+ } ## end if ($expr =~ /^(\S.*)/)
+
+ # You have to give one to get one.
+ else {
+ print $OUT "Adding a watch-expression requires an expression\n"; # hint
+ }
+} ## end sub cmd_w
+
+=head3 C<cmd_W> - delete watch expressions (command)
+
+This command accepts either a watch expression to be removed from the list
+of watch expressions, or C<*> to delete them all.
+
+If C<*> is specified, we simply empty the watch expression list and the
+watch expression value list. We also turn off the bit that says we've got
+watch expressions.
+
+If an expression (or partial expression) is specified, we pattern-match
+through the expressions and remove the ones that match. We also discard
+the corresponding values. If no watch expressions are left, we turn off
+the I<watching expressions> bit.
+
+=cut
+
+sub cmd_W {
+ my $cmd = shift;
+ my $expr = shift || '';
+
+ # Delete them all.
+ if ( $expr eq '*' ) {
+
+ # Not watching now.
+ $trace &= ~2;
+
+ print $OUT "Deleting all watch expressions ...\n";
+
+ # And all gone.
+ @to_watch = @old_watch = ();
+ }
+
+ # Delete one of them.
+ elsif ( $expr =~ /^(\S.*)/ ) {
+
+ # Where we are in the list.
+ my $i_cnt = 0;
+
+ # For each expression ...
+ foreach (@to_watch) {
+ my $val = $to_watch[$i_cnt];
+
+ # Does this one match the command argument?
+ if ( $val eq $expr ) { # =~ m/^\Q$i$/) {
+ # Yes. Turn it off, and its value too.
+ splice( @to_watch, $i_cnt, 1 );
+ splice( @old_watch, $i_cnt, 1 );
+ }
+ $i_cnt++;
+ } ## end foreach (@to_watch)
+
+ # We don't bother to turn watching off because
+ # a) we don't want to stop calling watchfunction() it it exists
+ # b) foreach over a null list doesn't do anything anyway
+
+ } ## end elsif ($expr =~ /^(\S.*)/)
+
+ # No command arguments entered.
+ else {
+ print $OUT
+ "Deleting a watch-expression requires an expression, or '*' for all\n"
+ ; # hint
+ }
+} ## end sub cmd_W
+
+### END of the API section
+
+=head1 SUPPORT ROUTINES
+
+These are general support routines that are used in a number of places
+throughout the debugger.
+
+=head2 save
+
+save() saves the user's versions of globals that would mess us up in C<@saved>,
+and installs the versions we like better.
+
+=cut
+
+sub save {
+
+ # Save eval failure, command failure, extended OS error, output field
+ # separator, input record separator, output record separator and
+ # the warning setting.
+ @saved = ( $@, $!, $^E, $,, $/, $\, $^W );
+
+ $, = ""; # output field separator is null string
+ $/ = "\n"; # input record separator is newline
+ $\ = ""; # output record separator is null string
+ $^W = 0; # warnings are off
+} ## end sub save
+
+=head2 C<print_lineinfo> - show where we are now
+
+print_lineinfo prints whatever it is that it is handed; it prints it to the
+C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows
+us to feed line information to a slave editor without messing up the
+debugger output.
+
+=cut
+
+sub print_lineinfo {
+
+ # Make the terminal sensible if we're not the primary debugger.
+ resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
+ local $\ = '';
+ local $, = '';
+ print $LINEINFO @_;
+} ## end sub print_lineinfo
+
+=head2 C<postponed_sub>
+
+Handles setting postponed breakpoints in subroutines once they're compiled.
+For breakpoints, we use C<DB::find_sub> to locate the source file and line
+range for the subroutine, then mark the file as having a breakpoint,
+temporarily switch the C<*dbline> glob over to the source file, and then
+search the given range of lines to find a breakable line. If we find one,
+we set the breakpoint on it, deleting the breakpoint from C<%postponed>.
+
+=cut
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub postponed_sub {
+
+ # Get the subroutine name.
+ my $subname = shift;
+
+ # If this is a 'break +<n> if <condition>' ...
+ if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) {
+
+ # If there's no offset, use '+0'.
+ my $offset = $1 || 0;
+
+ # find_sub's value is 'fullpath-filename:start-stop'. It's
+ # possible that the filename might have colons in it too.
+ my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ );
+ if ($i) {
+
+ # We got the start line. Add the offset '+<n>' from
+ # $postponed{subname}.
+ $i += $offset;
+
+ # Switch to the file this sub is in, temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ # No warnings, please.
+ local $^W = 0; # != 0 is magical below
+
+ # This file's got a breakpoint in it.
+ $had_breakpoints{$file} |= 1;
+
+ # Last line in file.
+ my $max = $#dbline;
+
+ # Search forward until we hit a breakable line or get to
+ # the end of the file.
+ ++$i until $dbline[$i] != 0 or $i >= $max;
+
+ # Copy the breakpoint in and delete it from %postponed.
+ $dbline{$i} = delete $postponed{$subname};
+ } ## end if ($i)
+
+ # find_sub didn't find the sub.
+ else {
+ local $\ = '';
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ return;
+ } ## end if ($postponed{$subname...
+ elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 }
+
+ #print $OUT "In postponed_sub for `$subname'.\n";
+} ## end sub postponed_sub
+
+=head2 C<postponed>
+
+Called after each required file is compiled, but before it is executed;
+also called if the name of a just-compiled subroutine is a key of
+C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>,
+etc.) into the just-compiled code.
+
+If this is a C<require>'d file, the incoming parameter is the glob
+C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file.
+
+If it's a subroutine, the incoming parameter is the subroutine name.
+
+=cut
+
+sub postponed {
+
+ # If there's a break, process it.
+ if ($ImmediateStop) {
+
+ # Right, we've stopped. Turn it off.
+ $ImmediateStop = 0;
+
+ # Enter the command loop when DB::DB gets called.
+ $signal = 1;
+ }
+
+ # If this is a subroutine, let postponed_sub() deal with it.
+ return &postponed_sub unless ref \$_[0] eq 'GLOB';
+
+ # Not a subroutine. Deal with the file.
+ local *dbline = shift;
+ my $filename = $dbline;
+ $filename =~ s/^_<//;
+ local $\ = '';
+ $signal = 1, print $OUT "'$filename' loaded...\n"
+ if $break_on_load{$filename};
+ print_lineinfo( ' ' x $stack_depth, "Package $filename.\n" ) if $frame;
+
+ # Do we have any breakpoints to put in this file?
+ return unless $postponed_file{$filename};
+
+ # Yes. Mark this file as having breakpoints.
+ $had_breakpoints{$filename} |= 1;
+
+ # "Cannot be done: unsufficient magic" - we can't just put the
+ # breakpoints saved in %postponed_file into %dbline by assigning
+ # the whole hash; we have to do it one item at a time for the
+ # breakpoints to be set properly.
+ #%dbline = %{$postponed_file{$filename}};
+
+ # Set the breakpoints, one at a time.
+ my $key;
+
+ for $key ( keys %{ $postponed_file{$filename} } ) {
+
+ # Stash the saved breakpoint into the current file's magic line array.
+ $dbline{$key} = ${ $postponed_file{$filename} }{$key};
+ }
+
+ # This file's been compiled; discard the stored breakpoints.
+ delete $postponed_file{$filename};
+
+} ## end sub postponed
+
+=head2 C<dumpit>
+
+C<dumpit> is the debugger's wrapper around dumpvar.pl.
+
+It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and
+a reference to a variable (the thing to be dumped) as its input.
+
+The incoming filehandle is selected for output (C<dumpvar.pl> is printing to
+the currently-selected filehandle, thank you very much). The current
+values of the package globals C<$single> and C<$trace> are backed up in
+lexicals, and they are turned off (this keeps the debugger from trying
+to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to
+preserve its current value and it is set to zero to prevent entry/exit
+messages from printing, and C<$doret> is localized as well and set to -2 to
+prevent return values from being shown.
+
+C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
+tries to load it (note: if you have a C<dumpvar.pl> ahead of the
+installed version in C<@INC>, yours will be used instead. Possible security
+problem?).
+
+It then checks to see if the subroutine C<main::dumpValue> is now defined
+(it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
+localizes the globals necessary for things to be sane when C<main::dumpValue()>
+is called, and picks up the variable to be dumped from the parameter list.
+
+It checks the package global C<%options> to see if there's a C<dumpDepth>
+specified. If not, -1 is assumed; if so, the supplied value gets passed on to
+C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
+structure: -1 means dump everything.
+
+C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
+warning.
+
+In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored
+and we then return to the caller.
+
+=cut
+
+sub dumpit {
+
+ # Save the current output filehandle and switch to the one
+ # passed in as the first parameter.
+ local ($savout) = select(shift);
+
+ # Save current settings of $single and $trace, and then turn them off.
+ my $osingle = $single;
+ my $otrace = $trace;
+ $single = $trace = 0;
+
+ # XXX Okay, what do $frame and $doret do, again?
+ local $frame = 0;
+ local $doret = -2;
+
+ # Load dumpvar.pl unless we've already got the sub we need from it.
+ unless ( defined &main::dumpValue ) {
+ do 'dumpvar.pl' or die $@;
+ }
+
+ # If the load succeeded (or we already had dumpvalue()), go ahead
+ # and dump things.
+ if ( defined &main::dumpValue ) {
+ local $\ = '';
+ local $, = '';
+ local $" = ' ';
+ my $v = shift;
+ my $maxdepth = shift || $option{dumpDepth};
+ $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
+ &main::dumpValue( $v, $maxdepth );
+ } ## end if (defined &main::dumpValue)
+
+ # Oops, couldn't load dumpvar.pl.
+ else {
+ local $\ = '';
+ print $OUT "dumpvar.pl not available.\n";
+ }
+
+ # Reset $single and $trace to their old values.
+ $single = $osingle;
+ $trace = $otrace;
+
+ # Restore the old filehandle.
+ select($savout);
+} ## end sub dumpit
+
+=head2 C<print_trace>
+
+C<print_trace>'s job is to print a stack trace. It does this via the
+C<dump_trace> routine, which actually does all the ferreting-out of the
+stack trace data. C<print_trace> takes care of formatting it nicely and
+printing it to the proper filehandle.
+
+Parameters:
+
+=over 4
+
+=item *
+
+The filehandle to print to.
+
+=item *
+
+How many frames to skip before starting trace.
+
+=item *
+
+How many frames to print.
+
+=item *
+
+A flag: if true, print a I<short> trace without filenames, line numbers, or arguments
+
+=back
+
+The original comment below seems to be noting that the traceback may not be
+correct if this routine is called in a tied method.
+
+=cut
+
+# Tied method do not create a context, so may get wrong message:
+
+sub print_trace {
+ local $\ = '';
+ my $fh = shift;
+
+ # If this is going to a slave editor, but we're not the primary
+ # debugger, reset it first.
+ resetterm(1)
+ if $fh eq $LINEINFO # slave editor
+ and $LINEINFO eq $OUT # normal output
+ and $term_pid != $$; # not the primary
+
+ # Collect the actual trace information to be formatted.
+ # This is an array of hashes of subroutine call info.
+ my @sub = dump_trace( $_[0] + 1, $_[1] );
+
+ # Grab the "short report" flag from @_.
+ my $short = $_[2]; # Print short report, next one for sub name
+
+ # Run through the traceback info, format it, and print it.
+ my $s;
+ for ( $i = 0 ; $i <= $#sub ; $i++ ) {
+
+ # Drop out if the user has lost interest and hit control-C.
+ last if $signal;
+
+ # Set the separator so arrys print nice.
+ local $" = ', ';
+
+ # Grab and stringify the arguments if they are there.
+ my $args =
+ defined $sub[$i]{args}
+ ? "(@{ $sub[$i]{args} })"
+ : '';
+
+ # Shorten them up if $maxtrace says they're too long.
+ $args = ( substr $args, 0, $maxtrace - 3 ) . '...'
+ if length $args > $maxtrace;
+
+ # Get the file name.
+ my $file = $sub[$i]{file};
+
+ # Put in a filename header if short is off.
+ $file = $file eq '-e' ? $file : "file `$file'" unless $short;
+
+ # Get the actual sub's name, and shorten to $maxtrace's requirement.
+ $s = $sub[$i]{sub};
+ $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace;
+
+ # Short report uses trimmed file and sub names.
+ if ($short) {
+ my $sub = @_ >= 4 ? $_[3] : $s;
+ print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
+ } ## end if ($short)
+
+ # Non-short report includes full names.
+ else {
+ print $fh "$sub[$i]{context} = $s$args"
+ . " called from $file"
+ . " line $sub[$i]{line}\n";
+ }
+ } ## end for ($i = 0 ; $i <= $#sub...
+} ## end sub print_trace
+
+=head2 dump_trace(skip[,count])
+
+Actually collect the traceback information available via C<caller()>. It does
+some filtering and cleanup of the data, but mostly it just collects it to
+make C<print_trace()>'s job easier.
+
+C<skip> defines the number of stack frames to be skipped, working backwards
+from the most current. C<count> determines the total number of frames to
+be returned; all of them (well, the first 10^9) are returned if C<count>
+is omitted.
+
+This routine returns a list of hashes, from most-recent to least-recent
+stack frame. Each has the following keys and values:
+
+=over 4
+
+=item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array)
+
+=item * C<sub> - subroutine name, or C<eval> information
+
+=item * C<args> - undef, or a reference to an array of arguments
+
+=item * C<file> - the file in which this item was defined (if any)
+
+=item * C<line> - the line on which it was defined
+
+=back
+
+=cut
+
+sub dump_trace {
+
+ # How many levels to skip.
+ my $skip = shift;
+
+ # How many levels to show. (1e9 is a cheap way of saying "all of them";
+ # it's unlikely that we'll have more than a billion stack frames. If you
+ # do, you've got an awfully big machine...)
+ my $count = shift || 1e9;
+
+ # We increment skip because caller(1) is the first level *back* from
+ # the current one. Add $skip to the count of frames so we have a
+ # simple stop criterion, counting from $skip to $count+$skip.
+ $skip++;
+ $count += $skip;
+
+ # These variables are used to capture output from caller();
+ my ( $p, $file, $line, $sub, $h, $context );
+
+ my ( $e, $r, @a, @sub, $args );
+
+ # XXX Okay... why'd we do that?
+ my $nothard = not $frame & 8;
+ local $frame = 0;
+
+ # Do not want to trace this.
+ my $otrace = $trace;
+ $trace = 0;
+
+ # Start out at the skip count.
+ # If we haven't reached the number of frames requested, and caller() is
+ # still returning something, stay in the loop. (If we pass the requested
+ # number of stack frames, or we run out - caller() returns nothing - we
+ # quit.
+ # Up the stack frame index to go back one more level each time.
+ for (
+ $i = $skip ;
+ $i < $count
+ and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ;
+ $i++
+ )
+ {
+
+ # Go through the arguments and save them for later.
+ @a = ();
+ for $arg (@args) {
+ my $type;
+ if ( not defined $arg ) { # undefined parameter
+ push @a, "undef";
+ }
+
+ elsif ( $nothard and tied $arg ) { # tied parameter
+ push @a, "tied";
+ }
+ elsif ( $nothard and $type = ref $arg ) { # reference
+ push @a, "ref($type)";
+ }
+ else { # can be stringified
+ local $_ =
+ "$arg"; # Safe to stringify now - should not call f().
+
+ # Backslash any single-quotes or backslashes.
+ s/([\'\\])/\\$1/g;
+
+ # Single-quote it unless it's a number or a colon-separated
+ # name.
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+
+ # Turn high-bit characters into meta-whatever.
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+
+ # Turn control characters into ^-whatever.
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+
+ push( @a, $_ );
+ } ## end else [ if (not defined $arg)
+ } ## end for $arg (@args)
+
+ # If context is true, this is array (@)context.
+ # If context is false, this is scalar ($) context.
+ # If neither, context isn't defined. (This is apparently a 'can't
+ # happen' trap.)
+ $context = $context ? '@' : ( defined $context ? "\$" : '.' );
+
+ # if the sub has args ($h true), make an anonymous array of the
+ # dumped args.
+ $args = $h ? [@a] : undef;
+
+ # remove trailing newline-whitespace-semicolon-end of line sequence
+ # from the eval text, if any.
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+
+ # Escape backslashed single-quotes again if necessary.
+ $e =~ s/([\\\'])/\\$1/g if $e;
+
+ # if the require flag is true, the eval text is from a require.
+ if ($r) {
+ $sub = "require '$e'";
+ }
+
+ # if it's false, the eval text is really from an eval.
+ elsif ( defined $r ) {
+ $sub = "eval '$e'";
+ }
+
+ # If the sub is '(eval)', this is a block eval, meaning we don't
+ # know what the eval'ed text actually was.
+ elsif ( $sub eq '(eval)' ) {
+ $sub = "eval {...}";
+ }
+
+ # Stick the collected information into @sub as an anonymous hash.
+ push(
+ @sub,
+ {
+ context => $context,
+ sub => $sub,
+ args => $args,
+ file => $file,
+ line => $line
+ }
+ );
+
+ # Stop processing frames if the user hit control-C.
+ last if $signal;
+ } ## end for ($i = $skip ; $i < ...
+
+ # Restore the trace value again.
+ $trace = $otrace;
+ @sub;
+} ## end sub dump_trace
+
+=head2 C<action()>
+
+C<action()> takes input provided as the argument to an add-action command,
+either pre- or post-, and makes sure it's a complete command. It doesn't do
+any fancy parsing; it just keeps reading input until it gets a string
+without a trailing backslash.
+
+=cut
+
+sub action {
+ my $action = shift;
+
+ while ( $action =~ s/\\$// ) {
+
+ # We have a backslash on the end. Read more.
+ $action .= &gets;
+ } ## end while ($action =~ s/\\$//)
+
+ # Return the assembled action.
+ $action;
+} ## end sub action
+
+=head2 unbalanced
+
+This routine mostly just packages up a regular expression to be used
+to check that the thing it's being matched against has properly-matched
+curly braces.
+
+Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which
+speeds things up by only creating the qr//'ed expression once; if it's
+already defined, we don't try to define it again. A speed hack.
+
+=cut
+
+sub unbalanced {
+
+ # I hate using globals!
+ $balanced_brace_re ||= qr{
+ ^ \{
+ (?:
+ (?> [^{}] + ) # Non-parens without backtracking
+ |
+ (??{ $balanced_brace_re }) # Group with matching parens
+ ) *
+ \} $
+ }x;
+ return $_[0] !~ m/$balanced_brace_re/;
+} ## end sub unbalanced
+
+=head2 C<gets()>
+
+C<gets()> is a primitive (very primitive) routine to read continuations.
+It was devised for reading continuations for actions.
+it just reads more input with C<readline()> and returns it.
+
+=cut
+
+sub gets {
+ &readline("cont: ");
+}
+
+=head2 C<DB::system()> - handle calls to<system()> without messing up the debugger
+
+The C<system()> function assumes that it can just go ahead and use STDIN and
+STDOUT, but under the debugger, we want it to use the debugger's input and
+outout filehandles.
+
+C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes
+the debugger's IN and OUT filehandles for them. It does the C<system()> call,
+and then puts everything back again.
+
+=cut
+
+sub system {
+
+ # We save, change, then restore STDIN and STDOUT to avoid fork() since
+ # some non-Unix systems can do system() but have problems with fork().
+ open( SAVEIN, "<&STDIN" ) || &warn("Can't save STDIN");
+ open( SAVEOUT, ">&STDOUT" ) || &warn("Can't save STDOUT");
+ open( STDIN, "<&IN" ) || &warn("Can't redirect STDIN");
+ open( STDOUT, ">&OUT" ) || &warn("Can't redirect STDOUT");
+
+ # XXX: using csh or tcsh destroys sigint retvals!
+ system(@_);
+ open( STDIN, "<&SAVEIN" ) || &warn("Can't restore STDIN");
+ open( STDOUT, ">&SAVEOUT" ) || &warn("Can't restore STDOUT");
+ close(SAVEIN);
+ close(SAVEOUT);
+
+ # most of the $? crud was coping with broken cshisms
+ if ( $? >> 8 ) {
+ &warn( "(Command exited ", ( $? >> 8 ), ")\n" );
+ }
+ elsif ($?) {
+ &warn(
+ "(Command died of SIG#",
+ ( $? & 127 ),
+ ( ( $? & 128 ) ? " -- core dumped" : "" ),
+ ")", "\n"
+ );
+ } ## end elsif ($?)
+
+ return $?;
+
+} ## end sub system
+
+=head1 TTY MANAGEMENT
+
+The subs here do some of the terminal management for multiple debuggers.
+
+=head2 setterm
+
+Top-level function called when we want to set up a new terminal for use
+by the debugger.
+
+If the C<noTTY> debugger option was set, we'll either use the terminal
+supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous>
+to find one. If we're a forked debugger, we call C<resetterm> to try to
+get a whole new terminal if we can.
+
+In either case, we set up the terminal next. If the C<ReadLine> option was
+true, we'll get a C<Term::ReadLine> object for the current terminal and save
+the appropriate attributes. We then
+
+=cut
+
+sub setterm {
+
+ # Load Term::Readline, but quietly; don't debug it and don't trace it.
+ local $frame = 0;
+ local $doret = -2;
+ eval { require Term::ReadLine } or die $@;
+
+ # If noTTY is set, but we have a TTY name, go ahead and hook up to it.
+ if ($notty) {
+ if ($tty) {
+ my ( $i, $o ) = split $tty, /,/;
+ $o = $i unless defined $o;
+ open( IN, "<$i" ) or die "Cannot open TTY `$i' for read: $!";
+ open( OUT, ">$o" ) or die "Cannot open TTY `$o' for write: $!";
+ $IN = \*IN;
+ $OUT = \*OUT;
+ my $sel = select($OUT);
+ $| = 1;
+ select($sel);
+ } ## end if ($tty)
+
+ # We don't have a TTY - try to find one via Term::Rendezvous.
+ else {
+ eval "require Term::Rendezvous;" or die;
+
+ # See if we have anything to pass to Term::Rendezvous.
+ # Use $HOME/.perldbtty$$ if not.
+ my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$";
+
+ # Rendezvous and get the filehandles.
+ my $term_rv = new Term::Rendezvous $rv;
+ $IN = $term_rv->IN;
+ $OUT = $term_rv->OUT;
+ } ## end else [ if ($tty)
+ } ## end if ($notty)
+
+ # We're a daughter debugger. Try to fork off another TTY.
+ if ( $term_pid eq '-1' ) { # In a TTY with another debugger
+ resetterm(2);
+ }
+
+ # If we shouldn't use Term::ReadLine, don't.
+ if ( !$rl ) {
+ $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ }
+
+ # We're using Term::ReadLine. Get all the attributes for this terminal.
+ else {
+ $term = new Term::ReadLine 'perldb', $IN, $OUT;
+
+ $rl_attribs = $term->Attribs;
+ $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
+ if defined $rl_attribs->{basic_word_break_characters}
+ and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1;
+ $rl_attribs->{special_prefixes} = '$@&%';
+ $rl_attribs->{completer_word_break_characters} .= '$@&%';
+ $rl_attribs->{completion_function} = \&db_complete;
+ } ## end else [ if (!$rl)
+
+ # Set up the LINEINFO filehandle.
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+
+ $term->MinLine(2);
+
+ &load_hist();
+
+ if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
+ $term->SetHistory(@hist);
+ }
+
+ # XXX Ornaments are turned on unconditionally, which is not
+ # always a good thing.
+ ornaments($ornaments) if defined $ornaments;
+ $term_pid = $$;
+} ## end sub setterm
+
+sub load_hist {
+ $histfile //= option_val("HistFile", undef);
+ return unless defined $histfile;
+ open my $fh, "<", $histfile or return;
+ local $/ = "\n";
+ @hist = ();
+ while (<$fh>) {
+ chomp;
+ push @hist, $_;
+ }
+ close $fh;
+}
+
+sub save_hist {
+ return unless defined $histfile;
+ eval { require File::Path } or return;
+ eval { require File::Basename } or return;
+ File::Path::mkpath(File::Basename::dirname($histfile));
+ open my $fh, ">", $histfile or die "Could not open '$histfile': $!";
+ $histsize //= option_val("HistSize",100);
+ my @copy = grep { $_ ne '?' } @hist;
+ my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0;
+ for ($start .. $#copy) {
+ print $fh "$copy[$_]\n";
+ }
+ close $fh or die "Could not write '$histfile': $!";
+}
+
+=head1 GET_FORK_TTY EXAMPLE FUNCTIONS
+
+When the process being debugged forks, or the process invokes a command
+via C<system()> which starts a new debugger, we need to be able to get a new
+C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes
+fight over the terminal, and you can never quite be sure who's going to get the
+input you're typing.
+
+C<get_fork_TTY> is a glob-aliased function which calls the real function that
+is tasked with doing all the necessary operating system mojo to get a new
+TTY (and probably another window) and to direct the new debugger to read and
+write there.
+
+The debugger provides C<get_fork_TTY> functions which work for X Windows,
+OS/2, and Mac OS X. Other systems are not supported. You are encouraged
+to write C<get_fork_TTY> functions which work for I<your> platform
+and contribute them.
+
+=head3 C<xterm_get_fork_TTY>
+
+This function provides the C<get_fork_TTY> function for X windows. If a
+program running under the debugger forks, a new <xterm> window is opened and
+the subsidiary debugger is directed there.
+
+The C<open()> call is of particular note here. We have the new C<xterm>
+we're spawning route file number 3 to STDOUT, and then execute the C<tty>
+command (which prints the device name of the TTY we'll want to use for input
+and output to STDOUT, then C<sleep> for a very long time, routing this output
+to file number 3. This way we can simply read from the <XT> filehandle (which
+is STDOUT from the I<commands> we ran) to get the TTY we want to use.
+
+Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
+properly set up.
+
+=cut
+
+sub xterm_get_fork_TTY {
+ ( my $name = $0 ) =~ s,^.*[/\\],,s;
+ open XT,
+qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
+ sleep 10000000' |];
+
+ # Get the output from 'tty' and clean it up a little.
+ my $tty = <XT>;
+ chomp $tty;
+
+ $pidprompt = ''; # Shown anyway in titlebar
+
+ # We need $term defined or we can not switch to the newly created xterm
+ if ($tty ne '' && !defined $term) {
+ eval { require Term::ReadLine } or die $@;
+ if ( !$rl ) {
+ $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ }
+ else {
+ $term = new Term::ReadLine 'perldb', $IN, $OUT;
+ }
+ }
+ # There's our new TTY.
+ return $tty;
+} ## end sub xterm_get_fork_TTY
+
+=head3 C<os2_get_fork_TTY>
+
+XXX It behooves an OS/2 expert to write the necessary documentation for this!
+
+=cut
+
+# This example function resets $IN, $OUT itself
+my $c_pipe = 0;
+sub os2_get_fork_TTY { # A simplification of the following (and works without):
+ local $\ = '';
+ ( my $name = $0 ) =~ s,^.*[/\\],,s;
+ my %opt = ( title => "Daughter Perl debugger $pids $name",
+ ($rl ? (read_by_key => 1) : ()) );
+ require OS2::Process;
+ my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) }
+ or return;
+ $pidprompt = ''; # Shown anyway in titlebar
+ reset_IN_OUT($in, $out);
+ $tty = '*reset*';
+ return ''; # Indicate that reset_IN_OUT is called
+} ## end sub os2_get_fork_TTY
+
+=head3 C<macosx_get_fork_TTY>
+
+The Mac OS X version uses AppleScript to tell Terminal.app to create
+a new window.
+
+=cut
+
+# Notes about Terminal.app's AppleScript support,
+# (aka things that might break in future OS versions).
+#
+# The "do script" command doesn't return a reference to the new window
+# it creates, but since it appears frontmost and windows are enumerated
+# front to back, we can use "first window" === "window 1".
+#
+# Since "do script" is implemented by supplying the argument (plus a
+# return character) as terminal input, there's a potential race condition
+# where the debugger could beat the shell to reading the command.
+# To prevent this, we wait for the screen to clear before proceeding.
+#
+# 10.3 and 10.4:
+# There's no direct accessor for the tty device name, so we fiddle
+# with the window title options until it says what we want.
+#
+# 10.5:
+# There _is_ a direct accessor for the tty device name, _and_ there's
+# a new possible component of the window title (the name of the settings
+# set). A separate version is needed.
+
+my @script_versions=
+
+ ([237, <<'__LEOPARD__'],
+tell application "Terminal"
+ do script "clear;exec sleep 100000"
+ tell first tab of first window
+ copy tty to thetty
+ set custom title to "forked perl debugger"
+ set title displays custom title to true
+ repeat while (length of first paragraph of (get contents)) > 0
+ delay 0.1
+ end repeat
+ end tell
+end tell
+thetty
+__LEOPARD__
+
+ [100, <<'__JAGUAR_TIGER__'],
+tell application "Terminal"
+ do script "clear;exec sleep 100000"
+ tell first window
+ set title displays shell path to false
+ set title displays window size to false
+ set title displays file name to false
+ set title displays device name to true
+ set title displays custom title to true
+ set custom title to ""
+ copy "/dev/" & name to thetty
+ set custom title to "forked perl debugger"
+ repeat while (length of first paragraph of (get contents)) > 0
+ delay 0.1
+ end repeat
+ end tell
+end tell
+thetty
+__JAGUAR_TIGER__
+
+);
+
+sub macosx_get_fork_TTY
+{
+ my($version,$script,$pipe,$tty);
+
+ return unless $version=$ENV{TERM_PROGRAM_VERSION};
+ foreach my $entry (@script_versions) {
+ if ($version>=$entry->[0]) {
+ $script=$entry->[1];
+ last;
+ }
+ }
+ return unless defined($script);
+ return unless open($pipe,'-|','/usr/bin/osascript','-e',$script);
+ $tty=readline($pipe);
+ close($pipe);
+ return unless defined($tty) && $tty =~ m(^/dev/);
+ chomp $tty;
+ return $tty;
+}
+
+=head2 C<create_IN_OUT($flags)>
+
+Create a new pair of filehandles, pointing to a new TTY. If impossible,
+try to diagnose why.
+
+Flags are:
+
+=over 4
+
+=item * 1 - Don't know how to create a new TTY.
+
+=item * 2 - Debugger has forked, but we can't get a new TTY.
+
+=item * 4 - standard debugger startup is happening.
+
+=back
+
+=cut
+
+sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
+
+ # If we know how to get a new TTY, do it! $in will have
+ # the TTY name if get_fork_TTY works.
+ my $in = &get_fork_TTY if defined &get_fork_TTY;
+
+ # It used to be that
+ $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
+
+ if ( not defined $in ) {
+ my $why = shift;
+
+ # We don't know how.
+ print_help(<<EOP) if $why == 1;
+I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
+EOP
+
+ # Forked debugger.
+ print_help(<<EOP) if $why == 2;
+I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
+ This may be an asynchronous session, so the parent debugger may be active.
+EOP
+
+ # Note that both debuggers are fighting over the same input.
+ print_help(<<EOP) if $why != 4;
+ Since two debuggers fight for the same TTY, input is severely entangled.
+
+EOP
+ print_help(<<EOP);
+ I know how to switch the output to a different window in xterms, OS/2
+ consoles, and Mac OS X Terminal.app only. For a manual switch, put the name
+ of the created I<TTY> in B<\$DB::fork_TTY>, or define a function
+ B<DB::get_fork_TTY()> returning this.
+
+ On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
+ by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
+
+EOP
+ } ## end if (not defined $in)
+ elsif ( $in ne '' ) {
+ TTY($in);
+ }
+ else {
+ $console = ''; # Indicate no need to open-from-the-console
+ }
+ undef $fork_TTY;
+} ## end sub create_IN_OUT
+
+=head2 C<resetterm>
+
+Handles rejiggering the prompt when we've forked off a new debugger.
+
+If the new debugger happened because of a C<system()> that invoked a
+program under the debugger, the arrow between the old pid and the new
+in the prompt has I<two> dashes instead of one.
+
+We take the current list of pids and add this one to the end. If there
+isn't any list yet, we make one up out of the initial pid associated with
+the terminal and our new pid, sticking an arrow (either one-dashed or
+two dashed) in between them.
+
+If C<CreateTTY> is off, or C<resetterm> was called with no arguments,
+we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead
+and try to do that.
+
+=cut
+
+sub resetterm { # We forked, so we need a different TTY
+
+ # Needs to be passed to create_IN_OUT() as well.
+ my $in = shift;
+
+ # resetterm(2): got in here because of a system() starting a debugger.
+ # resetterm(1): just forked.
+ my $systemed = $in > 1 ? '-' : '';
+
+ # If there's already a list of pids, add this to the end.
+ if ($pids) {
+ $pids =~ s/\]/$systemed->$$]/;
+ }
+
+ # No pid list. Time to make one.
+ else {
+ $pids = "[$term_pid->$$]";
+ }
+
+ # The prompt we're going to be using for this debugger.
+ $pidprompt = $pids;
+
+ # We now 0wnz this terminal.
+ $term_pid = $$;
+
+ # Just return if we're not supposed to try to create a new TTY.
+ return unless $CreateTTY & $in;
+
+ # Try to create a new IN/OUT pair.
+ create_IN_OUT($in);
+} ## end sub resetterm
+
+=head2 C<readline>
+
+First, we handle stuff in the typeahead buffer. If there is any, we shift off
+the next line, print a message saying we got it, add it to the terminal
+history (if possible), and return it.
+
+If there's nothing in the typeahead buffer, check the command filehandle stack.
+If there are any filehandles there, read from the last one, and return the line
+if we got one. If not, we pop the filehandle off and close it, and try the
+next one up the stack.
+
+If we've emptied the filehandle stack, we check to see if we've got a socket
+open, and we read that and return it if we do. If we don't, we just call the
+core C<readline()> and return its value.
+
+=cut
+
+sub readline {
+
+ # Localize to prevent it from being smashed in the program being debugged.
+ local $.;
+
+ # Pull a line out of the typeahead if there's stuff there.
+ if (@typeahead) {
+
+ # How many lines left.
+ my $left = @typeahead;
+
+ # Get the next line.
+ my $got = shift @typeahead;
+
+ # Print a message saying we got input from the typeahead.
+ local $\ = '';
+ print $OUT "auto(-$left)", shift, $got, "\n";
+
+ # Add it to the terminal history (if possible).
+ $term->AddHistory($got)
+ if length($got) > 1
+ and defined $term->Features->{addHistory};
+ return $got;
+ } ## end if (@typeahead)
+
+ # We really need to read some input. Turn off entry/exit trace and
+ # return value printing.
+ local $frame = 0;
+ local $doret = -2;
+
+ # If there are stacked filehandles to read from ...
+ while (@cmdfhs) {
+
+ # Read from the last one in the stack.
+ my $line = CORE::readline( $cmdfhs[-1] );
+
+ # If we got a line ...
+ defined $line
+ ? ( print $OUT ">> $line" and return $line ) # Echo and return
+ : close pop @cmdfhs; # Pop and close
+ } ## end while (@cmdfhs)
+
+ # Nothing on the filehandle stack. Socket?
+ if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) {
+
+ # Send anyting we have to send.
+ $OUT->write( join( '', @_ ) );
+
+ # Receive anything there is to receive.
+ $stuff;
+ my $stuff = '';
+ my $buf;
+ do {
+ $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?"
+ # XXX Don't know. You tell me.
+ } while length $buf and ($stuff .= $buf) !~ /\n/;
+
+ # What we got.
+ $stuff;
+ } ## end if (ref $OUT and UNIVERSAL::isa...
+
+ # No socket. Just read from the terminal.
+ else {
+ $term->readline(@_);
+ }
+} ## end sub readline
+
+=head1 OPTIONS SUPPORT ROUTINES
+
+These routines handle listing and setting option values.
+
+=head2 C<dump_option> - list the current value of an option setting
+
+This routine uses C<option_val> to look up the value for an option.
+It cleans up escaped single-quotes and then displays the option and
+its value.
+
+=cut
+
+sub dump_option {
+ my ( $opt, $val ) = @_;
+ $val = option_val( $opt, 'N/A' );
+ $val =~ s/([\\\'])/\\$1/g;
+ printf $OUT "%20s = '%s'\n", $opt, $val;
+} ## end sub dump_option
+
+sub options2remember {
+ foreach my $k (@RememberOnROptions) {
+ $option{$k} = option_val( $k, 'N/A' );
+ }
+ return %option;
+}
+
+=head2 C<option_val> - find the current value of an option
+
+This can't just be a simple hash lookup because of the indirect way that
+the option values are stored. Some are retrieved by calling a subroutine,
+some are just variables.
+
+You must supply a default value to be used in case the option isn't set.
+
+=cut
+
+sub option_val {
+ my ( $opt, $default ) = @_;
+ my $val;
+
+ # Does this option exist, and is it a variable?
+ # If so, retrieve the value via the value in %optionVars.
+ if ( defined $optionVars{$opt}
+ and defined ${ $optionVars{$opt} } )
+ {
+ $val = ${ $optionVars{$opt} };
+ }
+
+ # Does this option exist, and it's a subroutine?
+ # If so, call the subroutine via the ref in %optionAction
+ # and capture the value.
+ elsif ( defined $optionAction{$opt}
+ and defined &{ $optionAction{$opt} } )
+ {
+ $val = &{ $optionAction{$opt} }();
+ }
+
+ # If there's an action or variable for the supplied option,
+ # but no value was set, use the default.
+ elsif (defined $optionAction{$opt} and not defined $option{$opt}
+ or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} } )
+ {
+ $val = $default;
+ }
+
+ # Otherwise, do the simple hash lookup.
+ else {
+ $val = $option{$opt};
+ }
+
+ # If the value isn't defined, use the default.
+ # Then return whatever the value is.
+ $val = $default unless defined $val;
+ $val;
+} ## end sub option_val
+
+=head2 C<parse_options>
+
+Handles the parsing and execution of option setting/displaying commands.
+
+An option entered by itself is assumed to be I<set me to 1> (the default value)
+if the option is a boolean one. If not, the user is prompted to enter a valid
+value or to query the current value (via C<option? >).
+
+If C<option=value> is entered, we try to extract a quoted string from the
+value (if it is quoted). If it's not, we just use the whole value as-is.
+
+We load any modules required to service this option, and then we set it: if
+it just gets stuck in a variable, we do that; if there's a subroutine to
+handle setting the option, we call that.
+
+Finally, if we're running in interactive mode, we display the effect of the
+user's command back to the terminal, skipping this if we're setting things
+during initialization.
+
+=cut
+
+sub parse_options {
+ local ($_) = @_;
+ local $\ = '';
+
+ # These options need a value. Don't allow them to be clobbered by accident.
+ my %opt_needs_val = map { ( $_ => 1 ) } qw{
+ dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
+ pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet
+ };
+
+ while (length) {
+ my $val_defaulted;
+
+ # Clean off excess leading whitespace.
+ s/^\s+// && next;
+
+ # Options are always all word characters, followed by a non-word
+ # separator.
+ s/^(\w+)(\W?)// or print( $OUT "Invalid option `$_'\n" ), last;
+ my ( $opt, $sep ) = ( $1, $2 );
+
+ # Make sure that such an option exists.
+ my $matches = grep( /^\Q$opt/ && ( $option = $_ ), @options )
+ || grep( /^\Q$opt/i && ( $option = $_ ), @options );
+
+ print( $OUT "Unknown option `$opt'\n" ), next unless $matches;
+ print( $OUT "Ambiguous option `$opt'\n" ), next if $matches > 1;
+ my $val;
+
+ # '?' as separator means query, but must have whitespace after it.
+ if ( "?" eq $sep ) {
+ print( $OUT "Option query `$opt?' followed by non-space `$_'\n" ),
+ last
+ if /^\S/;
+
+ #&dump_option($opt);
+ } ## end if ("?" eq $sep)
+
+ # Separator is whitespace (or just a carriage return).
+ # They're going for a default, which we assume is 1.
+ elsif ( $sep !~ /\S/ ) {
+ $val_defaulted = 1;
+ $val = "1"; # this is an evil default; make 'em set it!
+ }
+
+ # Separator is =. Trying to set a value.
+ elsif ( $sep eq "=" ) {
+
+ # If quoted, extract a quoted string.
+ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
+ my $quote = $1;
+ ( $val = $2 ) =~ s/\\([$quote\\])/$1/g;
+ }
+
+ # Not quoted. Use the whole thing. Warn about 'option='.
+ else {
+ s/^(\S*)//;
+ $val = $1;
+ print OUT qq(Option better cleared using $opt=""\n)
+ unless length $val;
+ } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x)
+
+ } ## end elsif ($sep eq "=")
+
+ # "Quoted" with [], <>, or {}.
+ else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
+ my ($end) =
+ "\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #}
+ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)//
+ or print( $OUT "Unclosed option value `$opt$sep$_'\n" ), last;
+ ( $val = $1 ) =~ s/\\([\\$end])/$1/g;
+ } ## end else [ if ("?" eq $sep)
+
+ # Exclude non-booleans from getting set to 1 by default.
+ if ( $opt_needs_val{$option} && $val_defaulted ) {
+ my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O';
+ print $OUT
+"Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
+ next;
+ } ## end if ($opt_needs_val{$option...
+
+ # Save the option value.
+ $option{$option} = $val if defined $val;
+
+ # Load any module that this option requires.
+ eval qq{
+ local \$frame = 0;
+ local \$doret = -2;
+ require '$optionRequire{$option}';
+ 1;
+ } || die # XXX: shouldn't happen
+ if defined $optionRequire{$option}
+ && defined $val;
+
+ # Set it.
+ # Stick it in the proper variable if it goes in a variable.
+ ${ $optionVars{$option} } = $val
+ if defined $optionVars{$option}
+ && defined $val;
+
+ # Call the appropriate sub if it gets set via sub.
+ &{ $optionAction{$option} }($val)
+ if defined $optionAction{$option}
+ && defined &{ $optionAction{$option} }
+ && defined $val;
+
+ # Not initialization - echo the value we set it to.
+ dump_option($option) unless $OUT eq \*STDERR;
+ } ## end while (length)
+} ## end sub parse_options
+
+=head1 RESTART SUPPORT
+
+These routines are used to store (and restore) lists of items in environment
+variables during a restart.
+
+=head2 set_list
+
+Set_list packages up items to be stored in a set of environment variables
+(VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing
+the values). Values outside the standard ASCII charset are stored by encoding
+then as hexadecimal values.
+
+=cut
+
+sub set_list {
+ my ( $stem, @list ) = @_;
+ my $val;
+
+ # VAR_n: how many we have. Scalar assignment gets the number of items.
+ $ENV{"${stem}_n"} = @list;
+
+ # Grab each item in the list, escape the backslashes, encode the non-ASCII
+ # as hex, and then save in the appropriate VAR_0, VAR_1, etc.
+ for $i ( 0 .. $#list ) {
+ $val = $list[$i];
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
+ $ENV{"${stem}_$i"} = $val;
+ } ## end for $i (0 .. $#list)
+} ## end sub set_list
+
+=head2 get_list
+
+Reverse the set_list operation: grab VAR_n to see how many we should be getting
+back, and then pull VAR_0, VAR_1. etc. back out.
+
+=cut
+
+sub get_list {
+ my $stem = shift;
+ my @list;
+ my $n = delete $ENV{"${stem}_n"};
+ my $val;
+ for $i ( 0 .. $n - 1 ) {
+ $val = delete $ENV{"${stem}_$i"};
+ $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
+ push @list, $val;
+ }
+ @list;
+} ## end sub get_list
+
+=head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT
+
+=head2 catch()
+
+The C<catch()> subroutine is the essence of fast and low-impact. We simply
+set an already-existing global scalar variable to a constant value. This
+avoids allocating any memory possibly in the middle of something that will
+get all confused if we do, particularly under I<unsafe signals>.
+
+=cut
+
+sub catch {
+ $signal = 1;
+ return; # Put nothing on the stack - malloc/free land!
+}
+
+=head2 C<warn()>
+
+C<warn> emits a warning, by joining together its arguments and printing
+them, with couple of fillips.
+
+If the composited message I<doesn't> end with a newline, we automatically
+add C<$!> and a newline to the end of the message. The subroutine expects $OUT
+to be set to the filehandle to be used to output warnings; it makes no
+assumptions about what filehandles are available.
+
+=cut
+
+sub warn {
+ my ($msg) = join( "", @_ );
+ $msg .= ": $!\n" unless $msg =~ /\n$/;
+ local $\ = '';
+ print $OUT $msg;
+} ## end sub warn
+
+=head1 INITIALIZATION TTY SUPPORT
+
+=head2 C<reset_IN_OUT>
+
+This routine handles restoring the debugger's input and output filehandles
+after we've tried and failed to move them elsewhere. In addition, it assigns
+the debugger's output filehandle to $LINEINFO if it was already open there.
+
+=cut
+
+sub reset_IN_OUT {
+ my $switch_li = $LINEINFO eq $OUT;
+
+ # If there's a term and it's able to get a new tty, try to get one.
+ if ( $term and $term->Features->{newTTY} ) {
+ ( $IN, $OUT ) = ( shift, shift );
+ $term->newTTY( $IN, $OUT );
+ }
+
+ # This term can't get a new tty now. Better luck later.
+ elsif ($term) {
+ &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
+ }
+
+ # Set the filehndles up as they were.
+ else {
+ ( $IN, $OUT ) = ( shift, shift );
+ }
+
+ # Unbuffer the output filehandle.
+ my $o = select $OUT;
+ $| = 1;
+ select $o;
+
+ # Point LINEINFO to the same output filehandle if it was there before.
+ $LINEINFO = $OUT if $switch_li;
+} ## end sub reset_IN_OUT
+
+=head1 OPTION SUPPORT ROUTINES
+
+The following routines are used to process some of the more complicated
+debugger options.
+
+=head2 C<TTY>
+
+Sets the input and output filehandles to the specified files or pipes.
+If the terminal supports switching, we go ahead and do it. If not, and
+there's already a terminal in place, we save the information to take effect
+on restart.
+
+If there's no terminal yet (for instance, during debugger initialization),
+we go ahead and set C<$console> and C<$tty> to the file indicated.
+
+=cut
+
+sub TTY {
+
+ if ( @_ and $term and $term->Features->{newTTY} ) {
+
+ # This terminal supports switching to a new TTY.
+ # Can be a list of two files, or on string containing both names,
+ # comma-separated.
+ # XXX Should this perhaps be an assignment from @_?
+ my ( $in, $out ) = shift;
+ if ( $in =~ /,/ ) {
+
+ # Split list apart if supplied.
+ ( $in, $out ) = split /,/, $in, 2;
+ }
+ else {
+
+ # Use the same file for both input and output.
+ $out = $in;
+ }
+
+ # Open file onto the debugger's filehandles, if you can.
+ open IN, $in or die "cannot open `$in' for read: $!";
+ open OUT, ">$out" or die "cannot open `$out' for write: $!";
+
+ # Swap to the new filehandles.
+ reset_IN_OUT( \*IN, \*OUT );
+
+ # Save the setting for later.
+ return $tty = $in;
+ } ## end if (@_ and $term and $term...
+
+ # Terminal doesn't support new TTY, or doesn't support readline.
+ # Can't do it now, try restarting.
+ &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
+
+ # Useful if done through PERLDB_OPTS:
+ $console = $tty = shift if @_;
+
+ # Return whatever the TTY is.
+ $tty or $console;
+} ## end sub TTY
+
+=head2 C<noTTY>
+
+Sets the C<$notty> global, controlling whether or not the debugger tries to
+get a terminal to read from. If called after a terminal is already in place,
+we save the value to use it if we're restarted.
+
+=cut
+
+sub noTTY {
+ if ($term) {
+ &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
+ }
+ $notty = shift if @_;
+ $notty;
+} ## end sub noTTY
+
+=head2 C<ReadLine>
+
+Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
+(essentially, no C<readline> processing on this I<terminal>). Otherwise, we
+use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save
+the value in case a restart is done so we can change it then.
+
+=cut
+
+sub ReadLine {
+ if ($term) {
+ &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
+ }
+ $rl = shift if @_;
+ $rl;
+} ## end sub ReadLine
+
+=head2 C<RemotePort>
+
+Sets the port that the debugger will try to connect to when starting up.
+If the terminal's already been set up, we can't do it, but we remember the
+setting in case the user does a restart.
+
+=cut
+
+sub RemotePort {
+ if ($term) {
+ &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
+ }
+ $remoteport = shift if @_;
+ $remoteport;
+} ## end sub RemotePort
+
+=head2 C<tkRunning>
+
+Checks with the terminal to see if C<Tk> is running, and returns true or
+false. Returns false if the current terminal doesn't support C<readline>.
+
+=cut
+
+sub tkRunning {
+ if ( ${ $term->Features }{tkRunning} ) {
+ return $term->tkRunning(@_);
+ }
+ else {
+ local $\ = '';
+ print $OUT "tkRunning not supported by current ReadLine package.\n";
+ 0;
+ }
+} ## end sub tkRunning
+
+=head2 C<NonStop>
+
+Sets nonstop mode. If a terminal's already been set up, it's too late; the
+debugger remembers the setting in case you restart, though.
+
+=cut
+
+sub NonStop {
+ if ($term) {
+ &warn("Too late to set up NonStop mode, enabled on next `R'!\n")
+ if @_;
+ }
+ $runnonstop = shift if @_;
+ $runnonstop;
+} ## end sub NonStop
+
+sub DollarCaretP {
+ if ($term) {
+ &warn("Some flag changes could not take effect until next 'R'!\n")
+ if @_;
+ }
+ $^P = parse_DollarCaretP_flags(shift) if @_;
+ expand_DollarCaretP_flags($^P);
+}
+
+=head2 C<pager>
+
+Set up the C<$pager> variable. Adds a pipe to the front unless there's one
+there already.
+
+=cut
+
+sub pager {
+ if (@_) {
+ $pager = shift;
+ $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/;
+ }
+ $pager;
+} ## end sub pager
+
+=head2 C<shellBang>
+
+Sets the shell escape command, and generates a printable copy to be used
+in the help.
+
+=cut
+
+sub shellBang {
+
+ # If we got an argument, meta-quote it, and add '\b' if it
+ # ends in a word character.
+ if (@_) {
+ $sh = quotemeta shift;
+ $sh .= "\\b" if $sh =~ /\w$/;
+ }
+
+ # Generate the printable version for the help:
+ $psh = $sh; # copy it
+ $psh =~ s/\\b$//; # Take off trailing \b if any
+ $psh =~ s/\\(.)/$1/g; # De-escape
+ $psh; # return the printable version
+} ## end sub shellBang
+
+=head2 C<ornaments>
+
+If the terminal has its own ornaments, fetch them. Otherwise accept whatever
+was passed as the argument. (This means you can't override the terminal's
+ornaments.)
+
+=cut
+
+sub ornaments {
+ if ( defined $term ) {
+
+ # We don't want to show warning backtraces, but we do want die() ones.
+ local ( $warnLevel, $dieLevel ) = ( 0, 1 );
+
+ # No ornaments if the terminal doesn't support them.
+ return '' unless $term->Features->{ornaments};
+ eval { $term->ornaments(@_) } || '';
+ }
+
+ # Use what was passed in if we can't determine it ourselves.
+ else {
+ $ornaments = shift;
+ }
+} ## end sub ornaments
+
+=head2 C<recallCommand>
+
+Sets the recall command, and builds a printable version which will appear in
+the help text.
+
+=cut
+
+sub recallCommand {
+
+ # If there is input, metaquote it. Add '\b' if it ends with a word
+ # character.
+ if (@_) {
+ $rc = quotemeta shift;
+ $rc .= "\\b" if $rc =~ /\w$/;
+ }
+
+ # Build it into a printable version.
+ $prc = $rc; # Copy it
+ $prc =~ s/\\b$//; # Remove trailing \b
+ $prc =~ s/\\(.)/$1/g; # Remove escapes
+ $prc; # Return the printable version
+} ## end sub recallCommand
+
+=head2 C<LineInfo> - where the line number information goes
+
+Called with no arguments, returns the file or pipe that line info should go to.
+
+Called with an argument (a file or a pipe), it opens that onto the
+C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the
+file or pipe again to the caller.
+
+=cut
+
+sub LineInfo {
+ return $lineinfo unless @_;
+ $lineinfo = shift;
+
+ # If this is a valid "thing to be opened for output", tack a
+ # '>' onto the front.
+ my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo";
+
+ # If this is a pipe, the stream points to a slave editor.
+ $slave_editor = ( $stream =~ /^\|/ );
+
+ # Open it up and unbuffer it.
+ open( LINEINFO, "$stream" ) || &warn("Cannot open `$stream' for write");
+ $LINEINFO = \*LINEINFO;
+ my $save = select($LINEINFO);
+ $| = 1;
+ select($save);
+
+ # Hand the file or pipe back again.
+ $lineinfo;
+} ## end sub LineInfo
+
+=head1 COMMAND SUPPORT ROUTINES
+
+These subroutines provide functionality for various commands.
+
+=head2 C<list_modules>
+
+For the C<M> command: list modules loaded and their versions.
+Essentially just runs through the keys in %INC, picks each package's
+C<$VERSION> variable, gets the file name, and formats the information
+for output.
+
+=cut
+
+sub list_modules { # versions
+ my %version;
+ my $file;
+
+ # keys are the "as-loaded" name, values are the fully-qualified path
+ # to the file itself.
+ for ( keys %INC ) {
+ $file = $_; # get the module name
+ s,\.p[lm]$,,i; # remove '.pl' or '.pm'
+ s,/,::,g; # change '/' to '::'
+ s/^perl5db$/DB/; # Special case: debugger
+ # moves to package DB
+ s/^Term::ReadLine::readline$/readline/; # simplify readline
+
+ # If the package has a $VERSION package global (as all good packages
+ # should!) decode it and save as partial message.
+ if ( defined ${ $_ . '::VERSION' } ) {
+ $version{$file} = "${ $_ . '::VERSION' } from ";
+ }
+
+ # Finish up the message with the file the package came from.
+ $version{$file} .= $INC{$file};
+ } ## end for (keys %INC)
+
+ # Hey, dumpit() formats a hash nicely, so why not use it?
+ dumpit( $OUT, \%version );
+} ## end sub list_modules
+
+=head2 C<sethelp()>
+
+Sets up the monster string used to format and print the help.
+
+=head3 HELP MESSAGE FORMAT
+
+The help message is a peculiar format unto itself; it mixes C<pod> I<ornaments>
+(C<< B<> >> C<< I<> >>) with tabs to come up with a format that's fairly
+easy to parse and portable, but which still allows the help to be a little
+nicer than just plain text.
+
+Essentially, you define the command name (usually marked up with C<< B<> >>
+and C<< I<> >>), followed by a tab, and then the descriptive text, ending in a
+newline. The descriptive text can also be marked up in the same way. If you
+need to continue the descriptive text to another line, start that line with
+just tabs and then enter the marked-up text.
+
+If you are modifying the help text, I<be careful>. The help-string parser is
+not very sophisticated, and if you don't follow these rules it will mangle the
+help beyond hope until you fix the string.
+
+=cut
+
+sub sethelp {
+
+ # XXX: make sure there are tabs between the command and explanation,
+ # or print_help will screw up your formatting if you have
+ # eeevil ornaments enabled. This is an insane mess.
+
+ $help = "
+Help is currently only available for the new 5.8 command set.
+No help is available for the old command set.
+We assume you know what you're doing if you switch to it.
+
+B<T> Stack trace.
+B<s> [I<expr>] Single step [in I<expr>].
+B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
+<B<CR>> Repeat last B<n> or B<s> command.
+B<r> Return from current subroutine.
+B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
+ at the specified position.
+B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
+B<l> I<min>B<->I<max> List lines I<min> through I<max>.
+B<l> I<line> List single I<line>.
+B<l> I<subname> List first window of lines from subroutine.
+B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
+B<l> List next window of lines.
+B<-> List previous window of lines.
+B<v> [I<line>] View window around I<line>.
+B<.> Return to the executed line.
+B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
+ I<filename> may be either the full name of the file, or a regular
+ expression matching the full file name:
+ B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
+ Evals (with saved bodies) are considered to be filenames:
+ B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
+ (in the order of execution).
+B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
+B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
+B<L> [I<a|b|w>] List actions and or breakpoints and or watch-expressions.
+B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
+B<t> Toggle trace mode.
+B<t> I<expr> Trace through execution of I<expr>.
+B<b> Sets breakpoint on current line)
+B<b> [I<line>] [I<condition>]
+ Set breakpoint; I<line> defaults to the current execution line;
+ I<condition> breaks if it evaluates to true, defaults to '1'.
+B<b> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine.
+B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
+B<b> B<load> I<filename> Set breakpoint on 'require'ing the given file.
+B<b> B<postpone> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine after
+ it is compiled.
+B<b> B<compile> I<subname>
+ Stop after the subroutine is compiled.
+B<B> [I<line>] Delete the breakpoint for I<line>.
+B<B> I<*> Delete all breakpoints.
+B<a> [I<line>] I<command>
+ Set an action to be done before the I<line> is executed;
+ I<line> defaults to the current execution line.
+ Sequence is: check for breakpoint/watchpoint, print line
+ if necessary, do action, prompt user if necessary,
+ execute line.
+B<a> Does nothing
+B<A> [I<line>] Delete the action for I<line>.
+B<A> I<*> Delete all actions.
+B<w> I<expr> Add a global watch-expression.
+B<w> Does nothing
+B<W> I<expr> Delete a global watch-expression.
+B<W> I<*> Delete all watch-expressions.
+B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
+ Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
+B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
+B<x> I<expr> Evals expression in list context, dumps the result.
+B<m> I<expr> Evals expression in list context, prints methods callable
+ on the first element of the result.
+B<m> I<class> Prints methods callable via the given class.
+B<M> Show versions of loaded modules.
+B<i> I<class> Prints nested parents of given class.
+B<e> Display current thread id.
+B<E> Display all thread ids the current one will be identified: <n>.
+B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+
+B<<> ? List Perl commands to run before each prompt.
+B<<> I<expr> Define Perl command to run before each prompt.
+B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<< *> Delete the list of perl commands to run before each prompt.
+B<>> ? List Perl commands to run after each prompt.
+B<>> I<expr> Define Perl command to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<>>B< *> Delete the list of Perl commands to run after each prompt.
+B<{> I<db_command> Define debugger command to run before each prompt.
+B<{> ? List debugger commands to run before each prompt.
+B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<{ *> Delete the list of debugger commands to run before each prompt.
+B<$prc> I<number> Redo a previous command (default previous command).
+B<$prc> I<-number> Redo number'th-to-last command.
+B<$prc> I<pattern> Redo last command that started with I<pattern>.
+ See 'B<O> I<recallCommand>' too.
+B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
+ . (
+ $rc eq $sh
+ ? ""
+ : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
+ ) . "
+ See 'B<O> I<shellBang>' too.
+B<source> I<file> Execute I<file> containing debugger commands (may nest).
+B<save> I<file> Save current debugger session (actual history) to I<file>.
+B<rerun> Rerun session to current position.
+B<rerun> I<n> Rerun session to numbered command.
+B<rerun> I<-n> Rerun session to number'th-to-last command.
+B<H> I<-number> Display last number commands (default all).
+B<H> I<*> Delete complete history.
+B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
+B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
+B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
+I<command> Execute as a perl statement in current package.
+B<R> Pure-man-restart of debugger, some of debugger state
+ and command-line options may be lost.
+ Currently the following settings are preserved:
+ history, breakpoints and actions, debugger B<O>ptions
+ and the following command-line options: I<-w>, I<-I>, I<-e>.
+
+B<o> [I<opt>] ... Set boolean option to true
+B<o> [I<opt>B<?>] Query options
+B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
+ Set options. Use quotes if spaces in value.
+ I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
+ I<pager> program for output of \"|cmd\";
+ I<tkRunning> run Tk while prompting (with ReadLine);
+ I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
+ I<inhibit_exit> Allows stepping off the end of the script.
+ I<ImmediateStop> Debugger should stop as early as possible.
+ I<RemotePort> Remote hostname:port for remote debugging
+ The following options affect what happens with B<V>, B<X>, and B<x> commands:
+ I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
+ I<compactDump>, I<veryCompact> change style of array and hash dump;
+ I<globPrint> whether to print contents of globs;
+ I<DumpDBFiles> dump arrays holding debugged files;
+ I<DumpPackages> dump symbol tables of packages;
+ I<DumpReused> dump contents of \"reused\" addresses;
+ I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
+ I<bareStringify> Do not print the overload-stringified value;
+ Other options include:
+ I<PrintRet> affects printing of return value after B<r> command,
+ I<frame> affects printing messages on subroutine entry/exit.
+ I<AutoTrace> affects printing messages on possible breaking points.
+ I<maxTraceLen> gives max length of evals/args listed in stack trace.
+ I<ornaments> affects screen appearance of the command line.
+ I<CreateTTY> bits control attempts to create a new TTY on events:
+ 1: on fork() 2: debugger is started inside debugger
+ 4: on startup
+ During startup options are initialized from \$ENV{PERLDB_OPTS}.
+ You can put additional initialization options I<TTY>, I<noTTY>,
+ I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
+ `B<R>' after you set them).
+
+B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
+B<h> Summary of debugger commands.
+B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
+B<h h> Long help for debugger commands
+B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
+ named Perl I<manpage>, or on B<$doccmd> itself if omitted.
+ Set B<\$DB::doccmd> to change viewer.
+
+Type `|h h' for a paged display if this was too hard to read.
+
+"; # Fix balance of vi % matching: }}}}
+
+ # note: tabs in the following section are not-so-helpful
+ $summary = <<"END_SUM";
+I<List/search source lines:> I<Control script execution:>
+ B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
+ B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
+ B<v> [I<line>] View around line B<n> [I<expr>] Next, steps over subs
+ B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
+ B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
+ B<M> Show module versions B<c> [I<ln>|I<sub>] Continue until position
+I<Debugger controls:> B<L> List break/watch/actions
+ B<o> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
+ B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
+ B<$prc> [I<N>|I<pat>] Redo a previous command B<B> I<ln|*> Delete a/all breakpoints
+ B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
+ B<=> [I<a> I<val>] Define/list an alias B<A> I<ln|*> Delete a/all actions
+ B<h> [I<db_cmd>] Get help on command B<w> I<expr> Add a watch expression
+ B<h h> Complete help page B<W> I<expr|*> Delete a/all watch exprs
+ B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+ B<q> or B<^D> Quit B<R> Attempt a restart
+I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
+ B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
+ B<p> I<expr> Print expression (uses script's current package).
+ B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
+ B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
+ B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". B<i> I<class> inheritance tree.
+ B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+ B<e> Display thread id B<E> Display all thread ids.
+For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
+END_SUM
+
+ # ')}}; # Fix balance of vi % matching
+
+ # and this is really numb...
+ $pre580_help = "
+B<T> Stack trace.
+B<s> [I<expr>] Single step [in I<expr>].
+B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
+B<CR>> Repeat last B<n> or B<s> command.
+B<r> Return from current subroutine.
+B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
+ at the specified position.
+B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
+B<l> I<min>B<->I<max> List lines I<min> through I<max>.
+B<l> I<line> List single I<line>.
+B<l> I<subname> List first window of lines from subroutine.
+B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
+B<l> List next window of lines.
+B<-> List previous window of lines.
+B<w> [I<line>] List window around I<line>.
+B<.> Return to the executed line.
+B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
+ I<filename> may be either the full name of the file, or a regular
+ expression matching the full file name:
+ B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
+ Evals (with saved bodies) are considered to be filenames:
+ B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
+ (in the order of execution).
+B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
+B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
+B<L> List all breakpoints and actions.
+B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
+B<t> Toggle trace mode.
+B<t> I<expr> Trace through execution of I<expr>.
+B<b> [I<line>] [I<condition>]
+ Set breakpoint; I<line> defaults to the current execution line;
+ I<condition> breaks if it evaluates to true, defaults to '1'.
+B<b> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine.
+B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
+B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
+B<b> B<postpone> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine after
+ it is compiled.
+B<b> B<compile> I<subname>
+ Stop after the subroutine is compiled.
+B<d> [I<line>] Delete the breakpoint for I<line>.
+B<D> Delete all breakpoints.
+B<a> [I<line>] I<command>
+ Set an action to be done before the I<line> is executed;
+ I<line> defaults to the current execution line.
+ Sequence is: check for breakpoint/watchpoint, print line
+ if necessary, do action, prompt user if necessary,
+ execute line.
+B<a> [I<line>] Delete the action for I<line>.
+B<A> Delete all actions.
+B<W> I<expr> Add a global watch-expression.
+B<W> Delete all watch-expressions.
+B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
+ Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
+B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
+B<x> I<expr> Evals expression in list context, dumps the result.
+B<m> I<expr> Evals expression in list context, prints methods callable
+ on the first element of the result.
+B<m> I<class> Prints methods callable via the given class.
+
+B<<> ? List Perl commands to run before each prompt.
+B<<> I<expr> Define Perl command to run before each prompt.
+B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<>> ? List Perl commands to run after each prompt.
+B<>> I<expr> Define Perl command to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<{> I<db_command> Define debugger command to run before each prompt.
+B<{> ? List debugger commands to run before each prompt.
+B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<$prc> I<number> Redo a previous command (default previous command).
+B<$prc> I<-number> Redo number'th-to-last command.
+B<$prc> I<pattern> Redo last command that started with I<pattern>.
+ See 'B<O> I<recallCommand>' too.
+B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
+ . (
+ $rc eq $sh
+ ? ""
+ : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
+ ) . "
+ See 'B<O> I<shellBang>' too.
+B<source> I<file> Execute I<file> containing debugger commands (may nest).
+B<H> I<-number> Display last number commands (default all).
+B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
+B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
+B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
+I<command> Execute as a perl statement in current package.
+B<v> Show versions of loaded modules.
+B<R> Pure-man-restart of debugger, some of debugger state
+ and command-line options may be lost.
+ Currently the following settings are preserved:
+ history, breakpoints and actions, debugger B<O>ptions
+ and the following command-line options: I<-w>, I<-I>, I<-e>.
+
+B<O> [I<opt>] ... Set boolean option to true
+B<O> [I<opt>B<?>] Query options
+B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
+ Set options. Use quotes if spaces in value.
+ I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
+ I<pager> program for output of \"|cmd\";
+ I<tkRunning> run Tk while prompting (with ReadLine);
+ I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
+ I<inhibit_exit> Allows stepping off the end of the script.
+ I<ImmediateStop> Debugger should stop as early as possible.
+ I<RemotePort> Remote hostname:port for remote debugging
+ The following options affect what happens with B<V>, B<X>, and B<x> commands:
+ I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
+ I<compactDump>, I<veryCompact> change style of array and hash dump;
+ I<globPrint> whether to print contents of globs;
+ I<DumpDBFiles> dump arrays holding debugged files;
+ I<DumpPackages> dump symbol tables of packages;
+ I<DumpReused> dump contents of \"reused\" addresses;
+ I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
+ I<bareStringify> Do not print the overload-stringified value;
+ Other options include:
+ I<PrintRet> affects printing of return value after B<r> command,
+ I<frame> affects printing messages on subroutine entry/exit.
+ I<AutoTrace> affects printing messages on possible breaking points.
+ I<maxTraceLen> gives max length of evals/args listed in stack trace.
+ I<ornaments> affects screen appearance of the command line.
+ I<CreateTTY> bits control attempts to create a new TTY on events:
+ 1: on fork() 2: debugger is started inside debugger
+ 4: on startup
+ During startup options are initialized from \$ENV{PERLDB_OPTS}.
+ You can put additional initialization options I<TTY>, I<noTTY>,
+ I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
+ `B<R>' after you set them).
+
+B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
+B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
+B<h h> Summary of debugger commands.
+B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
+ named Perl I<manpage>, or on B<$doccmd> itself if omitted.
+ Set B<\$DB::doccmd> to change viewer.
+
+Type `|h' for a paged display if this was too hard to read.
+
+"; # Fix balance of vi % matching: }}}}
+
+ # note: tabs in the following section are not-so-helpful
+ $pre580_summary = <<"END_SUM";
+I<List/search source lines:> I<Control script execution:>
+ B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
+ B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
+ B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
+ B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
+ B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
+ B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
+I<Debugger controls:> B<L> List break/watch/actions
+ B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
+ B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint
+ B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
+ B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
+ B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
+ B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
+ B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+ B<q> or B<^D> Quit B<R> Attempt a restart
+I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
+ B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
+ B<p> I<expr> Print expression (uses script's current package).
+ B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
+ B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
+ B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
+ B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
+END_SUM
+
+ # ')}}; # Fix balance of vi % matching
+
+} ## end sub sethelp
+
+=head2 C<print_help()>
+
+Most of what C<print_help> does is just text formatting. It finds the
+C<B> and C<I> ornaments, cleans them off, and substitutes the proper
+terminal control characters to simulate them (courtesy of
+C<Term::ReadLine::TermCap>).
+
+=cut
+
+sub print_help {
+ local $_ = shift;
+
+ # Restore proper alignment destroyed by eeevil I<> and B<>
+ # ornaments: A pox on both their houses!
+ #
+ # A help command will have everything up to and including
+ # the first tab sequence padded into a field 16 (or if indented 20)
+ # wide. If it's wider than that, an extra space will be added.
+ s{
+ ^ # only matters at start of line
+ ( \040{4} | \t )* # some subcommands are indented
+ ( < ? # so <CR> works
+ [BI] < [^\t\n] + ) # find an eeevil ornament
+ ( \t+ ) # original separation, discarded
+ ( .* ) # this will now start (no earlier) than
+ # column 16
+ } {
+ my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
+ my $clean = $command;
+ $clean =~ s/[BI]<([^>]*)>/$1/g;
+
+ # replace with this whole string:
+ ($leadwhite ? " " x 4 : "")
+ . $command
+ . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
+ . $text;
+
+ }mgex;
+
+ s{ # handle bold ornaments
+ B < ( [^>] + | > ) >
+ } {
+ $Term::ReadLine::TermCap::rl_term_set[2]
+ . $1
+ . $Term::ReadLine::TermCap::rl_term_set[3]
+ }gex;
+
+ s{ # handle italic ornaments
+ I < ( [^>] + | > ) >
+ } {
+ $Term::ReadLine::TermCap::rl_term_set[0]
+ . $1
+ . $Term::ReadLine::TermCap::rl_term_set[1]
+ }gex;
+
+ local $\ = '';
+ print $OUT $_;
+} ## end sub print_help
+
+=head2 C<fix_less>
+
+This routine does a lot of gyrations to be sure that the pager is C<less>.
+It checks for C<less> masquerading as C<more> and records the result in
+C<$ENV{LESS}> so we don't have to go through doing the stats again.
+
+=cut
+
+sub fix_less {
+
+ # We already know if this is set.
+ return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
+
+ # Pager is less for sure.
+ my $is_less = $pager =~ /\bless\b/;
+ if ( $pager =~ /\bmore\b/ ) {
+
+ # Nope, set to more. See what's out there.
+ my @st_more = stat('/usr/bin/more');
+ my @st_less = stat('/usr/bin/less');
+
+ # is it really less, pretending to be more?
+ $is_less = @st_more
+ && @st_less
+ && $st_more[0] == $st_less[0]
+ && $st_more[1] == $st_less[1];
+ } ## end if ($pager =~ /\bmore\b/)
+
+ # changes environment!
+ # 'r' added so we don't do (slow) stats again.
+ $ENV{LESS} .= 'r' if $is_less;
+} ## end sub fix_less
+
+=head1 DIE AND WARN MANAGEMENT
+
+=head2 C<diesignal>
+
+C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying
+to debug a debugger problem.
+
+It does its best to report the error that occurred, and then forces the
+program, debugger, and everything to die.
+
+=cut
+
+sub diesignal {
+
+ # No entry/exit messages.
+ local $frame = 0;
+
+ # No return value prints.
+ local $doret = -2;
+
+ # set the abort signal handling to the default (just terminate).
+ $SIG{'ABRT'} = 'DEFAULT';
+
+ # If we enter the signal handler recursively, kill myself with an
+ # abort signal (so we just terminate).
+ kill 'ABRT', $$ if $panic++;
+
+ # If we can show detailed info, do so.
+ if ( defined &Carp::longmess ) {
+
+ # Don't recursively enter the warn handler, since we're carping.
+ local $SIG{__WARN__} = '';
+
+ # Skip two levels before reporting traceback: we're skipping
+ # mydie and confess.
+ local $Carp::CarpLevel = 2; # mydie + confess
+
+ # Tell us all about it.
+ &warn( Carp::longmess("Signal @_") );
+ }
+
+ # No Carp. Tell us about the signal as best we can.
+ else {
+ local $\ = '';
+ print $DB::OUT "Got signal @_\n";
+ }
+
+ # Drop dead.
+ kill 'ABRT', $$;
+} ## end sub diesignal
+
+=head2 C<dbwarn>
+
+The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to
+be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>.
+
+=cut
+
+sub dbwarn {
+
+ # No entry/exit trace.
+ local $frame = 0;
+
+ # No return value printing.
+ local $doret = -2;
+
+ # Turn off warn and die handling to prevent recursive entries to this
+ # routine.
+ local $SIG{__WARN__} = '';
+ local $SIG{__DIE__} = '';
+
+ # Load Carp if we can. If $^S is false (current thing being compiled isn't
+ # done yet), we may not be able to do a require.
+ eval { require Carp }
+ if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+
+ # Use the core warn() unless Carp loaded OK.
+ CORE::warn( @_,
+ "\nCannot print stack trace, load with -MCarp option to see stack" ),
+ return
+ unless defined &Carp::longmess;
+
+ # Save the current values of $single and $trace, and then turn them off.
+ my ( $mysingle, $mytrace ) = ( $single, $trace );
+ $single = 0;
+ $trace = 0;
+
+ # We can call Carp::longmess without its being "debugged" (which we
+ # don't want - we just want to use it!). Capture this for later.
+ my $mess = Carp::longmess(@_);
+
+ # Restore $single and $trace to their original values.
+ ( $single, $trace ) = ( $mysingle, $mytrace );
+
+ # Use the debugger's own special way of printing warnings to print
+ # the stack trace message.
+ &warn($mess);
+} ## end sub dbwarn
+
+=head2 C<dbdie>
+
+The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace
+by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off
+single stepping and tracing during the call to C<Carp::longmess> to avoid
+debugging it - we just want to use it.
+
+If C<dieLevel> is zero, we let the program being debugged handle the
+exceptions. If it's 1, you get backtraces for any exception. If it's 2,
+the debugger takes over all exception handling, printing a backtrace and
+displaying the exception via its C<dbwarn()> routine.
+
+=cut
+
+sub dbdie {
+ local $frame = 0;
+ local $doret = -2;
+ local $SIG{__DIE__} = '';
+ local $SIG{__WARN__} = '';
+ my $i = 0;
+ my $ineval = 0;
+ my $sub;
+ if ( $dieLevel > 2 ) {
+ local $SIG{__WARN__} = \&dbwarn;
+ &warn(@_); # Yell no matter what
+ return;
+ }
+ if ( $dieLevel < 2 ) {
+ die @_ if $^S; # in eval propagate
+ }
+
+ # The code used to check $^S to see if compiliation of the current thing
+ # hadn't finished. We don't do it anymore, figuring eval is pretty stable.
+ eval { require Carp };
+
+ die( @_,
+ "\nCannot print stack trace, load with -MCarp option to see stack" )
+ unless defined &Carp::longmess;
+
+ # We do not want to debug this chunk (automatic disabling works
+ # inside DB::DB, but not in Carp). Save $single and $trace, turn them off,
+ # get the stack trace from Carp::longmess (if possible), restore $signal
+ # and $trace, and then die with the stack trace.
+ my ( $mysingle, $mytrace ) = ( $single, $trace );
+ $single = 0;
+ $trace = 0;
+ my $mess = "@_";
+ {
+
+ package Carp; # Do not include us in the list
+ eval { $mess = Carp::longmess(@_); };
+ }
+ ( $single, $trace ) = ( $mysingle, $mytrace );
+ die $mess;
+} ## end sub dbdie
+
+=head2 C<warnlevel()>
+
+Set the C<$DB::warnLevel> variable that stores the value of the
+C<warnLevel> option. Calling C<warnLevel()> with a positive value
+results in the debugger taking over all warning handlers. Setting
+C<warnLevel> to zero leaves any warning handlers set up by the program
+being debugged in place.
+
+=cut
+
+sub warnLevel {
+ if (@_) {
+ $prevwarn = $SIG{__WARN__} unless $warnLevel;
+ $warnLevel = shift;
+ if ($warnLevel) {
+ $SIG{__WARN__} = \&DB::dbwarn;
+ }
+ elsif ($prevwarn) {
+ $SIG{__WARN__} = $prevwarn;
+ } else {
+ undef $SIG{__WARN__};
+ }
+ } ## end if (@_)
+ $warnLevel;
+} ## end sub warnLevel
+
+=head2 C<dielevel>
+
+Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the
+C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to
+zero lets you use your own C<die()> handler.
+
+=cut
+
+sub dieLevel {
+ local $\ = '';
+ if (@_) {
+ $prevdie = $SIG{__DIE__} unless $dieLevel;
+ $dieLevel = shift;
+ if ($dieLevel) {
+
+ # Always set it to dbdie() for non-zero values.
+ $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
+
+ # No longer exists, so don't try to use it.
+ #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
+
+ # If we've finished initialization, mention that stack dumps
+ # are enabled, If dieLevel is 1, we won't stack dump if we die
+ # in an eval().
+ print $OUT "Stack dump during die enabled",
+ ( $dieLevel == 1 ? " outside of evals" : "" ), ".\n"
+ if $I_m_init;
+
+ # XXX This is probably obsolete, given that diehard() is gone.
+ print $OUT "Dump printed too.\n" if $dieLevel > 2;
+ } ## end if ($dieLevel)
+
+ # Put the old one back if there was one.
+ elsif ($prevdie) {
+ $SIG{__DIE__} = $prevdie;
+ print $OUT "Default die handler restored.\n";
+ } else {
+ undef $SIG{__DIE__};
+ print $OUT "Die handler removed.\n";
+ }
+ } ## end if (@_)
+ $dieLevel;
+} ## end sub dieLevel
+
+=head2 C<signalLevel>
+
+Number three in a series: set C<signalLevel> to zero to keep your own
+signal handler for C<SIGSEGV> and/or C<SIGBUS>. Otherwise, the debugger
+takes over and handles them with C<DB::diesignal()>.
+
+=cut
+
+sub signalLevel {
+ if (@_) {
+ $prevsegv = $SIG{SEGV} unless $signalLevel;
+ $prevbus = $SIG{BUS} unless $signalLevel;
+ $signalLevel = shift;
+ if ($signalLevel) {
+ $SIG{SEGV} = \&DB::diesignal;
+ $SIG{BUS} = \&DB::diesignal;
+ }
+ else {
+ $SIG{SEGV} = $prevsegv;
+ $SIG{BUS} = $prevbus;
+ }
+ } ## end if (@_)
+ $signalLevel;
+} ## end sub signalLevel
+
+=head1 SUBROUTINE DECODING SUPPORT
+
+These subroutines are used during the C<x> and C<X> commands to try to
+produce as much information as possible about a code reference. They use
+L<Devel::Peek> to try to find the glob in which this code reference lives
+(if it does) - this allows us to actually code references which correspond
+to named subroutines (including those aliased via glob assignment).
+
+=head2 C<CvGV_name()>
+
+Wrapper for C<CvGV_name_or_bust>; tries to get the name of a reference
+via that routine. If this fails, return the reference again (when the
+reference is stringified, it'll come out as C<SOMETHING(0x...)>).
+
+=cut
+
+sub CvGV_name {
+ my $in = shift;
+ my $name = CvGV_name_or_bust($in);
+ defined $name ? $name : $in;
+}
+
+=head2 C<CvGV_name_or_bust> I<coderef>
+
+Calls L<Devel::Peek> to try to find the glob the ref lives in; returns
+C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't
+find a glob for this ref.
+
+Returns C<< I<package>::I<glob name> >> if the code ref is found in a glob.
+
+=cut
+
+sub CvGV_name_or_bust {
+ my $in = shift;
+ return if $skipCvGV; # Backdoor to avoid problems if XS broken...
+ return unless ref $in;
+ $in = \&$in; # Hard reference...
+ eval { require Devel::Peek; 1 } or return;
+ my $gv = Devel::Peek::CvGV($in) or return;
+ *$gv{PACKAGE} . '::' . *$gv{NAME};
+} ## end sub CvGV_name_or_bust
+
+=head2 C<find_sub>
+
+A utility routine used in various places; finds the file where a subroutine
+was defined, and returns that filename and a line-number range.
+
+Tries to use C<@sub> first; if it can't find it there, it tries building a
+reference to the subroutine and uses C<CvGV_name_or_bust> to locate it,
+loading it into C<@sub> as a side effect (XXX I think). If it can't find it
+this way, it brute-force searches C<%sub>, checking for identical references.
+
+=cut
+
+sub find_sub {
+ my $subr = shift;
+ $sub{$subr} or do {
+ return unless defined &$subr;
+ my $name = CvGV_name_or_bust($subr);
+ my $data;
+ $data = $sub{$name} if defined $name;
+ return $data if defined $data;
+
+ # Old stupid way...
+ $subr = \&$subr; # Hard reference
+ my $s;
+ for ( keys %sub ) {
+ $s = $_, last if $subr eq \&$_;
+ }
+ $sub{$s} if $s;
+ } ## end do
+} ## end sub find_sub
+
+=head2 C<methods>
+
+A subroutine that uses the utility function C<methods_via> to find all the
+methods in the class corresponding to the current reference and in
+C<UNIVERSAL>.
+
+=cut
+
+sub methods {
+
+ # Figure out the class - either this is the class or it's a reference
+ # to something blessed into that class.
+ my $class = shift;
+ $class = ref $class if ref $class;
+
+ local %seen;
+
+ # Show the methods that this class has.
+ methods_via( $class, '', 1 );
+
+ # Show the methods that UNIVERSAL has.
+ methods_via( 'UNIVERSAL', 'UNIVERSAL', 0 );
+} ## end sub methods
+
+=head2 C<methods_via($class, $prefix, $crawl_upward)>
+
+C<methods_via> does the work of crawling up the C<@ISA> tree and reporting
+all the parent class methods. C<$class> is the name of the next class to
+try; C<$prefix> is the message prefix, which gets built up as we go up the
+C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go
+higher in the C<@ISA> tree, 0 if we should stop.
+
+=cut
+
+sub methods_via {
+
+ # If we've processed this class already, just quit.
+ my $class = shift;
+ return if $seen{$class}++;
+
+ # This is a package that is contributing the methods we're about to print.
+ my $prefix = shift;
+ my $prepend = $prefix ? "via $prefix: " : '';
+ my @to_print;
+
+ # Extract from all the symbols in this class.
+ while (my ($name, $glob) = each %{"${class}::"}) {
+ # references directly in the symbol table are Proxy Constant
+ # Subroutines, and are by their very nature defined
+ # Otherwise, check if the thing is a typeglob, and if it is, it decays
+ # to a subroutine reference, which can be tested by defined.
+ # $glob might also be the value -1 (from sub foo;)
+ # or (say) '$$' (from sub foo ($$);)
+ # \$glob will be SCALAR in both cases.
+ if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
+ && !$seen{$name}++) {
+ push @to_print, "$prepend$name\n";
+ }
+ }
+
+ {
+ local $\ = '';
+ local $, = '';
+ print $DB::OUT $_ foreach sort @to_print;
+ }
+
+ # If the $crawl_upward argument is false, just quit here.
+ return unless shift;
+
+ # $crawl_upward true: keep going up the tree.
+ # Find all the classes this one is a subclass of.
+ for $name ( @{"${class}::ISA"} ) {
+
+ # Set up the new prefix.
+ $prepend = $prefix ? $prefix . " -> $name" : $name;
+
+ # Crawl up the tree and keep trying to crawl up.
+ methods_via( $name, $prepend, 1 );
+ }
+} ## end sub methods_via
+
+=head2 C<setman> - figure out which command to use to show documentation
+
+Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly.
+
+=cut
+
+sub setman {
+ $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
+ ? "man" # O Happy Day!
+ : "perldoc"; # Alas, poor unfortunates
+} ## end sub setman
+
+=head2 C<runman> - run the appropriate command to show documentation
+
+Accepts a man page name; runs the appropriate command to display it (set up
+during debugger initialization). Uses C<DB::system> to avoid mucking up the
+program's STDIN and STDOUT.
+
+=cut
+
+sub runman {
+ my $page = shift;
+ unless ($page) {
+ &system("$doccmd $doccmd");
+ return;
+ }
+
+ # this way user can override, like with $doccmd="man -Mwhatever"
+ # or even just "man " to disable the path check.
+ unless ( $doccmd eq 'man' ) {
+ &system("$doccmd $page");
+ return;
+ }
+
+ $page = 'perl' if lc($page) eq 'help';
+
+ require Config;
+ my $man1dir = $Config::Config{'man1dir'};
+ my $man3dir = $Config::Config{'man3dir'};
+ for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ }
+ my $manpath = '';
+ $manpath .= "$man1dir:" if $man1dir =~ /\S/;
+ $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
+ chop $manpath if $manpath;
+
+ # harmless if missing, I figure
+ my $oldpath = $ENV{MANPATH};
+ $ENV{MANPATH} = $manpath if $manpath;
+ my $nopathopt = $^O =~ /dunno what goes here/;
+ if (
+ CORE::system(
+ $doccmd,
+
+ # I just *know* there are men without -M
+ ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
+ split ' ', $page
+ )
+ )
+ {
+ unless ( $page =~ /^perl\w/ ) {
+# do it this way because its easier to slurp in to keep up to date - clunky though.
+my @pods = qw(
+ 5004delta
+ 5005delta
+ 561delta
+ 56delta
+ 570delta
+ 571delta
+ 572delta
+ 573delta
+ 58delta
+ 581delta
+ 582delta
+ 583delta
+ 584delta
+ 590delta
+ 591delta
+ 592delta
+ aix
+ amiga
+ apio
+ api
+ apollo
+ artistic
+ beos
+ book
+ boot
+ bot
+ bs2000
+ call
+ ce
+ cheat
+ clib
+ cn
+ compile
+ cygwin
+ data
+ dbmfilter
+ debguts
+ debtut
+ debug
+ delta
+ dgux
+ diag
+ doc
+ dos
+ dsc
+ ebcdic
+ embed
+ epoc
+ faq1
+ faq2
+ faq3
+ faq4
+ faq5
+ faq6
+ faq7
+ faq8
+ faq9
+ faq
+ filter
+ fork
+ form
+ freebsd
+ func
+ gpl
+ guts
+ hack
+ hist
+ hpux
+ hurd
+ intern
+ intro
+ iol
+ ipc
+ irix
+ jp
+ ko
+ lexwarn
+ locale
+ lol
+ macos
+ macosx
+ modinstall
+ modlib
+ mod
+ modstyle
+ mpeix
+ netware
+ newmod
+ number
+ obj
+ opentut
+ op
+ os2
+ os390
+ os400
+ packtut
+ plan9
+ pod
+ podspec
+ port
+ qnx
+ ref
+ reftut
+ re
+ requick
+ reref
+ retut
+ run
+ sec
+ solaris
+ style
+ sub
+ syn
+ thrtut
+ tie
+ toc
+ todo
+ tooc
+ toot
+ trap
+ tru64
+ tw
+ unicode
+ uniintro
+ util
+ uts
+ var
+ vmesa
+ vms
+ vos
+ win32
+ xs
+ xstut
+);
+ if (grep { $page eq $_ } @pods) {
+ $page =~ s/^/perl/;
+ CORE::system( $doccmd,
+ ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
+ $page );
+ } ## end if (grep { $page eq $_...
+ } ## end unless ($page =~ /^perl\w/)
+ } ## end if (CORE::system($doccmd...
+ if ( defined $oldpath ) {
+ $ENV{MANPATH} = $manpath;
+ }
+ else {
+ delete $ENV{MANPATH};
+ }
+} ## end sub runman
+
+#use Carp; # This did break, left for debugging
+
+=head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK
+
+Because of the way the debugger interface to the Perl core is designed, any
+debugger package globals that C<DB::sub()> requires have to be defined before
+any subroutines can be called. These are defined in the second C<BEGIN> block.
+
+This block sets things up so that (basically) the world is sane
+before the debugger starts executing. We set up various variables that the
+debugger has to have set up before the Perl core starts running:
+
+=over 4
+
+=item *
+
+The debugger's own filehandles (copies of STD and STDOUT for now).
+
+=item *
+
+Characters for shell escapes, the recall command, and the history command.
+
+=item *
+
+The maximum recursion depth.
+
+=item *
+
+The size of a C<w> command's window.
+
+=item *
+
+The before-this-line context to be printed in a C<v> (view a window around this line) command.
+
+=item *
+
+The fact that we're not in a sub at all right now.
+
+=item *
+
+The default SIGINT handler for the debugger.
+
+=item *
+
+The appropriate value of the flag in C<$^D> that says the debugger is running
+
+=item *
+
+The current debugger recursion level
+
+=item *
+
+The list of postponed items and the C<$single> stack (XXX define this)
+
+=item *
+
+That we want no return values and no subroutine entry/exit trace.
+
+=back
+
+=cut
+
+# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
+
+BEGIN { # This does not compile, alas. (XXX eh?)
+ $IN = \*STDIN; # For bugs before DB::OUT has been opened
+ $OUT = \*STDERR; # For errors before DB::OUT has been opened
+
+ # Define characters used by command parsing.
+ $sh = '!'; # Shell escape (does not work)
+ $rc = ','; # Recall command (does not work)
+ @hist = ('?'); # Show history (does not work)
+ @truehist = (); # Can be saved for replay (per session)
+
+ # This defines the point at which you get the 'deep recursion'
+ # warning. It MUST be defined or the debugger will not load.
+ $deep = 100;
+
+ # Number of lines around the current one that are shown in the
+ # 'w' command.
+ $window = 10;
+
+ # How much before-the-current-line context the 'v' command should
+ # use in calculating the start of the window it will display.
+ $preview = 3;
+
+ # We're not in any sub yet, but we need this to be a defined value.
+ $sub = '';
+
+ # Set up the debugger's interrupt handler. It simply sets a flag
+ # ($signal) that DB::DB() will check before each command is executed.
+ $SIG{INT} = \&DB::catch;
+
+ # The following lines supposedly, if uncommented, allow the debugger to
+ # debug itself. Perhaps we can try that someday.
+ # This may be enabled to debug debugger:
+ #$warnLevel = 1 unless defined $warnLevel;
+ #$dieLevel = 1 unless defined $dieLevel;
+ #$signalLevel = 1 unless defined $signalLevel;
+
+ # This is the flag that says "a debugger is running, please call
+ # DB::DB and DB::sub". We will turn it on forcibly before we try to
+ # execute anything in the user's context, because we always want to
+ # get control back.
+ $db_stop = 0; # Compiler warning ...
+ $db_stop = 1 << 30; # ... because this is only used in an eval() later.
+
+ # This variable records how many levels we're nested in debugging. Used
+ # Used in the debugger prompt, and in determining whether it's all over or
+ # not.
+ $level = 0; # Level of recursive debugging
+
+ # "Triggers bug (?) in perl if we postpone this until runtime."
+ # XXX No details on this yet, or whether we should fix the bug instead
+ # of work around it. Stay tuned.
+ @postponed = @stack = (0);
+
+ # Used to track the current stack depth using the auto-stacked-variable
+ # trick.
+ $stack_depth = 0; # Localized repeatedly; simple way to track $#stack
+
+ # Don't print return values on exiting a subroutine.
+ $doret = -2;
+
+ # No extry/exit tracing.
+ $frame = 0;
+
+} ## end BEGIN
+
+BEGIN { $^W = $ini_warn; } # Switch warnings back
+
+=head1 READLINE SUPPORT - COMPLETION FUNCTION
+
+=head2 db_complete
+
+C<readline> support - adds command completion to basic C<readline>.
+
+Returns a list of possible completions to C<readline> when invoked. C<readline>
+will print the longest common substring following the text already entered.
+
+If there is only a single possible completion, C<readline> will use it in full.
+
+This code uses C<map> and C<grep> heavily to create lists of possible
+completion. Think LISP in this section.
+
+=cut
+
+sub db_complete {
+
+ # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
+ # $text is the text to be completed.
+ # $line is the incoming line typed by the user.
+ # $start is the start of the text to be completed in the incoming line.
+ my ( $text, $line, $start ) = @_;
+
+ # Save the initial text.
+ # The search pattern is current package, ::, extract the next qualifier
+ # Prefix and pack are set to undef.
+ my ( $itext, $search, $prefix, $pack ) =
+ ( $text, "^\Q${'package'}::\E([^:]+)\$" );
+
+=head3 C<b postpone|compile>
+
+=over 4
+
+=item *
+
+Find all the subroutines that might match in this package
+
+=item *
+
+Add C<postpone>, C<load>, and C<compile> as possibles (we may be completing the keyword itself)
+
+=item *
+
+Include all the rest of the subs that are known
+
+=item *
+
+C<grep> out the ones that match the text we have so far
+
+=item *
+
+Return this as the list of possible completions
+
+=back
+
+=cut
+
+ return sort grep /^\Q$text/, ( keys %sub ),
+ qw(postpone load compile), # subroutines
+ ( map { /$search/ ? ($1) : () } keys %sub )
+ if ( substr $line, 0, $start ) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
+
+=head3 C<b load>
+
+Get all the possible files from C<@INC> as it currently stands and
+select the ones that match the text so far.
+
+=cut
+
+ return sort grep /^\Q$text/, values %INC # files
+ if ( substr $line, 0, $start ) =~ /^\|*b\s+load\s+$/;
+
+=head3 C<V> (list variable) and C<m> (list modules)
+
+There are two entry points for these commands:
+
+=head4 Unqualified package names
+
+Get the top-level packages and grab everything that matches the text
+so far. For each match, recursively complete the partial packages to
+get all possible matching packages. Return this sorted list.
+
+=cut
+
+ return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) }
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages
+ if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
+
+=head4 Qualified package names
+
+Take a partially-qualified package and find all subpackages for it
+by getting all the subpackages for the package so far, matching all
+the subpackages against the text, and discarding all of them which
+start with 'main::'. Return this list.
+
+=cut
+
+ return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) }
+ grep !/^main::/, grep /^\Q$text/,
+ map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () } keys %{ $prefix . '::' }
+ if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/
+ and $text =~ /^(.*[^:])::?(\w*)$/
+ and $prefix = $1;
+
+=head3 C<f> - switch files
+
+Here, we want to get a fully-qualified filename for the C<f> command.
+Possibilities are:
+
+=over 4
+
+=item 1. The original source file itself
+
+=item 2. A file from C<@INC>
+
+=item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>).
+
+=back
+
+=cut
+
+ if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
+ # We might possibly want to switch to an eval (which has a "filename"
+ # like '(eval 9)'), so we may need to clean up the completion text
+ # before proceeding.
+ $prefix = length($1) - length($text);
+ $text = $1;
+
+=pod
+
+Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file>
+(C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these
+out of C<%main::>, add the initial source file, and extract the ones that
+match the completion text so far.
+
+=cut
+
+ return sort
+ map { substr $_, 2 + $prefix } grep /^_<\Q$text/, ( keys %main:: ),
+ $0;
+ } ## end if ($line =~ /^\|*f\s+(.*)/)
+
+=head3 Subroutine name completion
+
+We look through all of the defined subs (the keys of C<%sub>) and
+return both all the possible matches to the subroutine name plus
+all the matches qualified to the current package.
+
+=cut
+
+ if ( ( substr $text, 0, 1 ) eq '&' ) { # subroutines
+ $text = substr $text, 1;
+ $prefix = "&";
+ return sort map "$prefix$_", grep /^\Q$text/, ( keys %sub ),
+ (
+ map { /$search/ ? ($1) : () }
+ keys %sub
+ );
+ } ## end if ((substr $text, 0, ...
+
+=head3 Scalar, array, and hash completion: partially qualified package
+
+Much like the above, except we have to do a little more cleanup:
+
+=cut
+
+ if ( $text =~ /^[\$@%](.*)::(.*)/ ) { # symbols in a package
+
+=pod
+
+=over 4
+
+=item *
+
+Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified.
+
+=cut
+
+ $pack = ( $1 eq 'main' ? '' : $1 ) . '::';
+
+=pod
+
+=item *
+
+Figure out the prefix vs. what needs completing.
+
+=cut
+
+ $prefix = ( substr $text, 0, 1 ) . $1 . '::';
+ $text = $2;
+
+=pod
+
+=item *
+
+Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities.
+
+=cut
+
+ my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
+ keys %$pack;
+
+=pod
+
+=item *
+
+If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found.
+
+=cut
+
+ if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) {
+ return db_complete( $out[0], $line, $start );
+ }
+
+ # Return the list of possibles.
+ return sort @out;
+
+ } ## end if ($text =~ /^[\$@%](.*)::(.*)/)
+
+=pod
+
+=back
+
+=head3 Symbol completion: current package or package C<main>.
+
+=cut
+
+ if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main)
+=pod
+
+=over 4
+
+=item *
+
+If it's C<main>, delete main to just get C<::> leading.
+
+=cut
+
+ $pack = ( $package eq 'main' ? '' : $package ) . '::';
+
+=pod
+
+=item *
+
+We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
+
+=cut
+
+ $prefix = substr $text, 0, 1;
+ $text = substr $text, 1;
+
+ my @out;
+
+=pod
+
+=item *
+
+We look for the lexical scope above DB::DB and auto-complete lexical variables
+if PadWalker could be loaded.
+
+=cut
+
+ if (not $text =~ /::/ and eval "require PadWalker; 1" and not $@ ) {
+ my $level = 1;
+ while (1) {
+ my @info = caller($level);
+ $level++;
+ $level = -1, last
+ if not @info;
+ last if $info[3] eq 'DB::DB';
+ }
+ if ($level > 0) {
+ my $lexicals = PadWalker::peek_my($level);
+ push @out, grep /^\Q$prefix$text/, keys %$lexicals;
+ }
+ }
+
+=pod
+
+=item *
+
+If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols.
+
+=cut
+
+ push @out, map "$prefix$_", grep /^\Q$text/,
+ ( grep /^_?[a-zA-Z]/, keys %$pack ),
+ ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
+
+=item *
+
+If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
+
+=back
+
+=cut
+
+ if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) {
+ return db_complete( $out[0], $line, $start );
+ }
+
+ # Return the list of possibles.
+ return sort @out;
+ } ## end if ($text =~ /^[\$@%]/)
+
+=head3 Options
+
+We use C<option_val()> to look up the current value of the option. If there's
+only a single value, we complete the command in such a way that it is a
+complete command for setting the option in question. If there are multiple
+possible values, we generate a command consisting of the option plus a trailing
+question mark, which, if executed, will list the current value of the option.
+
+=cut
+
+ if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ )
+ { # Options after space
+ # We look for the text to be matched in the list of possible options,
+ # and fetch the current value.
+ my @out = grep /^\Q$text/, @options;
+ my $val = option_val( $out[0], undef );
+
+ # Set up a 'query option's value' command.
+ my $out = '? ';
+ if ( not defined $val or $val =~ /[\n\r]/ ) {
+
+ # There's really nothing else we can do.
+ }
+
+ # We have a value. Create a proper option-setting command.
+ elsif ( $val =~ /\s/ ) {
+
+ # XXX This may be an extraneous variable.
+ my $found;
+
+ # We'll want to quote the string (because of the embedded
+ # whtespace), but we want to make sure we don't end up with
+ # mismatched quote characters. We try several possibilities.
+ foreach $l ( split //, qq/\"\'\#\|/ ) {
+
+ # If we didn't find this quote character in the value,
+ # quote it using this quote character.
+ $out = "$l$val$l ", last if ( index $val, $l ) == -1;
+ }
+ } ## end elsif ($val =~ /\s/)
+
+ # Don't need any quotes.
+ else {
+ $out = "=$val ";
+ }
+
+ # If there were multiple possible values, return '? ', which
+ # makes the command into a query command. If there was just one,
+ # have readline append that.
+ $rl_attribs->{completer_terminator_character} =
+ ( @out == 1 ? $out : '? ' );
+
+ # Return list of possibilities.
+ return sort @out;
+ } ## end if ((substr $line, 0, ...
+
+=head3 Filename completion
+
+For entering filenames. We simply call C<readline>'s C<filename_list()>
+method with the completion text to get the possible completions.
+
+=cut
+
+ return $term->filename_list($text); # filenames
+
+} ## end sub db_complete
+
+=head1 MISCELLANEOUS SUPPORT FUNCTIONS
+
+Functions that possibly ought to be somewhere else.
+
+=head2 end_report
+
+Say we're done.
+
+=cut
+
+sub end_report {
+ local $\ = '';
+ print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n";
+}
+
+=head2 clean_ENV
+
+If we have $ini_pids, save it in the environment; else remove it from the
+environment. Used by the C<R> (restart) command.
+
+=cut
+
+sub clean_ENV {
+ if ( defined($ini_pids) ) {
+ $ENV{PERLDB_PIDS} = $ini_pids;
+ }
+ else {
+ delete( $ENV{PERLDB_PIDS} );
+ }
+} ## end sub clean_ENV
+
+# PERLDBf_... flag names from perl.h
+our ( %DollarCaretP_flags, %DollarCaretP_flags_r );
+
+BEGIN {
+ %DollarCaretP_flags = (
+ PERLDBf_SUB => 0x01, # Debug sub enter/exit
+ PERLDBf_LINE => 0x02, # Keep line #
+ PERLDBf_NOOPT => 0x04, # Switch off optimizations
+ PERLDBf_INTER => 0x08, # Preserve more data
+ PERLDBf_SUBLINE => 0x10, # Keep subr source lines
+ PERLDBf_SINGLE => 0x20, # Start with single-step on
+ PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
+ PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
+ PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
+ PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
+ PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"}
+ PERLDB_ALL => 0x33f, # No _NONAME, _GOTO
+ );
+ # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger
+ # doesn't need to set it. It's provided for the benefit of profilers and
+ # other code analysers.
+
+ %DollarCaretP_flags_r = reverse %DollarCaretP_flags;
+}
+
+sub parse_DollarCaretP_flags {
+ my $flags = shift;
+ $flags =~ s/^\s+//;
+ $flags =~ s/\s+$//;
+ my $acu = 0;
+ foreach my $f ( split /\s*\|\s*/, $flags ) {
+ my $value;
+ if ( $f =~ /^0x([[:xdigit:]]+)$/ ) {
+ $value = hex $1;
+ }
+ elsif ( $f =~ /^(\d+)$/ ) {
+ $value = int $1;
+ }
+ elsif ( $f =~ /^DEFAULT$/i ) {
+ $value = $DollarCaretP_flags{PERLDB_ALL};
+ }
+ else {
+ $f =~ /^(?:PERLDBf_)?(.*)$/i;
+ $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) };
+ unless ( defined $value ) {
+ print $OUT (
+ "Unrecognized \$^P flag '$f'!\n",
+ "Acceptable flags are: "
+ . join( ', ', sort keys %DollarCaretP_flags ),
+ ", and hexadecimal and decimal numbers.\n"
+ );
+ return undef;
+ }
+ }
+ $acu |= $value;
+ }
+ $acu;
+}
+
+sub expand_DollarCaretP_flags {
+ my $DollarCaretP = shift;
+ my @bits = (
+ map {
+ my $n = ( 1 << $_ );
+ ( $DollarCaretP & $n )
+ ? ( $DollarCaretP_flags_r{$n}
+ || sprintf( '0x%x', $n ) )
+ : ()
+ } 0 .. 31
+ );
+ return @bits ? join( '|', @bits ) : 0;
+}
+
+=over 4
+
+=item rerun
+
+Rerun the current session to:
+
+ rerun current position
+
+ rerun 4 command number 4
+
+ rerun -4 current command minus 4 (go back 4 steps)
+
+Whether this always makes sense, in the current context is unknowable, and is
+in part left as a useful exersize for the reader. This sub returns the
+appropriate arguments to rerun the current session.
+
+=cut
+
+sub rerun {
+ my $i = shift;
+ my @args;
+ pop(@truehist); # strim
+ unless (defined $truehist[$i]) {
+ print "Unable to return to non-existent command: $i\n";
+ } else {
+ $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist);
+ my @temp = @truehist; # store
+ push(@DB::typeahead, @truehist); # saved
+ @truehist = @hist = (); # flush
+ @args = &restart(); # setup
+ &get_list("PERLDB_HIST"); # clean
+ &set_list("PERLDB_HIST", @temp); # reset
+ }
+ return @args;
+}
+
+=item restart
+
+Restarting the debugger is a complex operation that occurs in several phases.
+First, we try to reconstruct the command line that was used to invoke Perl
+and the debugger.
+
+=cut
+
+sub restart {
+ # I may not be able to resurrect you, but here goes ...
+ print $OUT
+"Warning: some settings and command-line options may be lost!\n";
+ my ( @script, @flags, $cl );
+
+ # If warn was on before, turn it on again.
+ push @flags, '-w' if $ini_warn;
+
+ # Rebuild the -I flags that were on the initial
+ # command line.
+ for (@ini_INC) {
+ push @flags, '-I', $_;
+ }
+
+ # Turn on taint if it was on before.
+ push @flags, '-T' if ${^TAINT};
+
+ # Arrange for setting the old INC:
+ # Save the current @init_INC in the environment.
+ set_list( "PERLDB_INC", @ini_INC );
+
+ # If this was a perl one-liner, go to the "file"
+ # corresponding to the one-liner read all the lines
+ # out of it (except for the first one, which is going
+ # to be added back on again when 'perl -d' runs: that's
+ # the 'require perl5db.pl;' line), and add them back on
+ # to the command line to be executed.
+ if ( $0 eq '-e' ) {
+ for ( 1 .. $#{'::_<-e'} ) { # The first line is PERL5DB
+ chomp( $cl = ${'::_<-e'}[$_] );
+ push @script, '-e', $cl;
+ }
+ } ## end if ($0 eq '-e')
+
+ # Otherwise we just reuse the original name we had
+ # before.
+ else {
+ @script = $0;
+ }
+
+=pod
+
+After the command line has been reconstructed, the next step is to save
+the debugger's status in environment variables. The C<DB::set_list> routine
+is used to save aggregate variables (both hashes and arrays); scalars are
+just popped into environment variables directly.
+
+=cut
+
+ # If the terminal supported history, grab it and
+ # save that in the environment.
+ set_list( "PERLDB_HIST",
+ $term->Features->{getHistory}
+ ? $term->GetHistory
+ : @hist );
+
+ # Find all the files that were visited during this
+ # session (i.e., the debugger had magic hashes
+ # corresponding to them) and stick them in the environment.
+ my @had_breakpoints = keys %had_breakpoints;
+ set_list( "PERLDB_VISITED", @had_breakpoints );
+
+ # Save the debugger options we chose.
+ set_list( "PERLDB_OPT", %option );
+ # set_list( "PERLDB_OPT", options2remember() );
+
+ # Save the break-on-loads.
+ set_list( "PERLDB_ON_LOAD", %break_on_load );
+
+=pod
+
+The most complex part of this is the saving of all of the breakpoints. They
+can live in an awful lot of places, and we have to go through all of them,
+find the breakpoints, and then save them in the appropriate environment
+variable via C<DB::set_list>.
+
+=cut
+
+ # Go through all the breakpoints and make sure they're
+ # still valid.
+ my @hard;
+ for ( 0 .. $#had_breakpoints ) {
+
+ # We were in this file.
+ my $file = $had_breakpoints[$_];
+
+ # Grab that file's magic line hash.
+ *dbline = $main::{ '_<' . $file };
+
+ # Skip out if it doesn't exist, or if the breakpoint
+ # is in a postponed file (we'll do postponed ones
+ # later).
+ next unless %dbline or $postponed_file{$file};
+
+ # In an eval. This is a little harder, so we'll
+ # do more processing on that below.
+ ( push @hard, $file ), next
+ if $file =~ /^\(\w*eval/;
+
+ # XXX I have no idea what this is doing. Yet.
+ my @add;
+ @add = %{ $postponed_file{$file} }
+ if $postponed_file{$file};
+
+ # Save the list of all the breakpoints for this file.
+ set_list( "PERLDB_FILE_$_", %dbline, @add );
+ } ## end for (0 .. $#had_breakpoints)
+
+ # The breakpoint was inside an eval. This is a little
+ # more difficult. XXX and I don't understand it.
+ for (@hard) {
+ # Get over to the eval in question.
+ *dbline = $main::{ '_<' . $_ };
+ my ( $quoted, $sub, %subs, $line ) = quotemeta $_;
+ for $sub ( keys %sub ) {
+ next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
+ $subs{$sub} = [ $1, $2 ];
+ }
+ unless (%subs) {
+ print $OUT
+ "No subroutines in $_, ignoring breakpoints.\n";
+ next;
+ }
+ LINES: for $line ( keys %dbline ) {
+
+ # One breakpoint per sub only:
+ my ( $offset, $sub, $found );
+ SUBS: for $sub ( keys %subs ) {
+ if (
+ $subs{$sub}->[1] >=
+ $line # Not after the subroutine
+ and (
+ not defined $offset # Not caught
+ or $offset < 0
+ )
+ )
+ { # or badly caught
+ $found = $sub;
+ $offset = $line - $subs{$sub}->[0];
+ $offset = "+$offset", last SUBS
+ if $offset >= 0;
+ } ## end if ($subs{$sub}->[1] >=...
+ } ## end for $sub (keys %subs)
+ if ( defined $offset ) {
+ $postponed{$found} =
+ "break $offset if $dbline{$line}";
+ }
+ else {
+ print $OUT
+"Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ }
+ } ## end for $line (keys %dbline)
+ } ## end for (@hard)
+
+ # Save the other things that don't need to be
+ # processed.
+ set_list( "PERLDB_POSTPONE", %postponed );
+ set_list( "PERLDB_PRETYPE", @$pretype );
+ set_list( "PERLDB_PRE", @$pre );
+ set_list( "PERLDB_POST", @$post );
+ set_list( "PERLDB_TYPEAHEAD", @typeahead );
+
+ # We are oficially restarting.
+ $ENV{PERLDB_RESTART} = 1;
+
+ # We are junking all child debuggers.
+ delete $ENV{PERLDB_PIDS}; # Restore ini state
+
+ # Set this back to the initial pid.
+ $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
+
+=pod
+
+After all the debugger status has been saved, we take the command we built up
+and then return it, so we can C<exec()> it. The debugger will spot the
+C<PERLDB_RESTART> environment variable and realize it needs to reload its state
+from the environment.
+
+=cut
+
+ # And run Perl again. Add the "-d" flag, all the
+ # flags we built up, the script (whether a one-liner
+ # or a file), add on the -emacs flag for a slave editor,
+ # and then the old arguments.
+
+ return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS);
+
+}; # end restart
+
+=back
+
+=head1 END PROCESSING - THE C<END> BLOCK
+
+Come here at the very end of processing. We want to go into a
+loop where we allow the user to enter commands and interact with the
+debugger, but we don't want anything else to execute.
+
+First we set the C<$finished> variable, so that some commands that
+shouldn't be run after the end of program quit working.
+
+We then figure out whether we're truly done (as in the user entered a C<q>
+command, or we finished execution while running nonstop). If we aren't,
+we set C<$single> to 1 (causing the debugger to get control again).
+
+We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...>
+message and returns control to the debugger. Repeat.
+
+When the user finally enters a C<q> command, C<$fall_off_end> is set to
+1 and the C<END> block simply exits with C<$single> set to 0 (don't
+break, run to completion.).
+
+=cut
+
+END {
+ $finished = 1 if $inhibit_exit; # So that some commands may be disabled.
+ $fall_off_end = 1 unless $inhibit_exit;
+
+ # Do not stop in at_exit() and destructors on exit:
+ if ($fall_off_end or $runnonstop) {
+ &save_hist();
+ } else {
+ $DB::single = 1;
+ DB::fake::at_exit();
+ }
+} ## end END
+
+=head1 PRE-5.8 COMMANDS
+
+Some of the commands changed function quite a bit in the 5.8 command
+realignment, so much so that the old code had to be replaced completely.
+Because we wanted to retain the option of being able to go back to the
+former command set, we moved the old code off to this section.
+
+There's an awful lot of duplicated code here. We've duplicated the
+comments to keep things clear.
+
+=head2 Null command
+
+Does nothing. Used to I<turn off> commands.
+
+=cut
+
+sub cmd_pre580_null {
+
+ # do nothing...
+}
+
+=head2 Old C<a> command.
+
+This version added actions if you supplied them, and deleted them
+if you didn't.
+
+=cut
+
+sub cmd_pre580_a {
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Argument supplied. Add the action.
+ if ( $cmd =~ /^(\d*)\s*(.*)/ ) {
+
+ # If the line isn't there, use the current line.
+ $i = $1 || $line;
+ $j = $2;
+
+ # If there is an action ...
+ if ( length $j ) {
+
+ # ... but the line isn't breakable, skip it.
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i may not have an action.\n";
+ }
+ else {
+
+ # ... and the line is breakable:
+ # Mark that there's an action in this file.
+ $had_breakpoints{$filename} |= 2;
+
+ # Delete any current action.
+ $dbline{$i} =~ s/\0[^\0]*//;
+
+ # Add the new action, continuing the line as needed.
+ $dbline{$i} .= "\0" . action($j);
+ }
+ } ## end if (length $j)
+
+ # No action supplied.
+ else {
+
+ # Delete the action.
+ $dbline{$i} =~ s/\0[^\0]*//;
+
+ # Mark as having no break or action if nothing's left.
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ } ## end if ($cmd =~ /^(\d*)\s*(.*)/)
+} ## end sub cmd_pre580_a
+
+=head2 Old C<b> command
+
+Add breakpoints.
+
+=cut
+
+sub cmd_pre580_b {
+ my $xcmd = shift;
+ my $cmd = shift;
+ my $dbline = shift;
+
+ # Break on load.
+ if ( $cmd =~ /^load\b\s*(.*)/ ) {
+ my $file = $1;
+ $file =~ s/\s+$//;
+ &cmd_b_load($file);
+ }
+
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ( $cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
+
+ # Capture the condition if there is one. Make it true if none.
+ my $cond = length $3 ? $3 : '1';
+
+ # Save the sub name and set $break to 1 if $1 was 'postpone', 0
+ # if it was 'compile'.
+ my ( $subname, $break ) = ( $2, $1 eq 'postpone' );
+
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/\'/::/g;
+
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+
+ # Save the break type for this sub.
+ $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ } ## end elsif ($cmd =~ ...
+
+ # b <sub name> [<condition>]
+ elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+ my $subname = $1;
+ my $cond = length $2 ? $2 : '1';
+ &cmd_b_sub( $subname, $cond );
+ }
+
+ # b <line> [<condition>].
+ elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) {
+ my $i = $1 || $dbline;
+ my $cond = length $2 ? $2 : '1';
+ &cmd_b_line( $i, $cond );
+ }
+} ## end sub cmd_pre580_b
+
+=head2 Old C<D> command.
+
+Delete all breakpoints unconditionally.
+
+=cut
+
+sub cmd_pre580_D {
+ my $xcmd = shift;
+ my $cmd = shift;
+ if ( $cmd =~ /^\s*$/ ) {
+ print $OUT "Deleting all breakpoints...\n";
+
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ my $file;
+ for $file ( keys %had_breakpoints ) {
+
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ my $max = $#dbline;
+ my $was;
+
+ # For all lines in this file ...
+ for ( $i = 1 ; $i <= $max ; $i++ ) {
+
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
+
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ( $dbline{$i} =~ s/^\0?$// ) {
+
+ # Remove the entry altogether if no action is there.
+ delete $dbline{$i};
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for ($i = 1 ; $i <= $max...
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$file} &= ~1 ) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for $file (keys %had_breakpoints)
+
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ } ## end if ($cmd =~ /^\s*$/)
+} ## end sub cmd_pre580_D
+
+=head2 Old C<h> command
+
+Print help. Defaults to printing the long-form help; the 5.8 version
+prints the summary by default.
+
+=cut
+
+sub cmd_pre580_h {
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Print the *right* help, long format.
+ if ( $cmd =~ /^\s*$/ ) {
+ print_help($pre580_help);
+ }
+
+ # 'h h' - explicitly-requested summary.
+ elsif ( $cmd =~ /^h\s*/ ) {
+ print_help($pre580_summary);
+ }
+
+ # Find and print a command's help.
+ elsif ( $cmd =~ /^h\s+(\S.*)$/ ) {
+ my $asked = $1; # for proper errmsg
+ my $qasked = quotemeta($asked); # for searching
+ # XXX: finds CR but not <CR>
+ if (
+ $pre580_help =~ /^
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command name
+ /mx
+ )
+ {
+
+ while (
+ $pre580_help =~ /^
+ ( # The command help:
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command name
+ ([\s\S]*?) # Lines starting with tabs
+ \n # Final newline
+ )
+ (?!\s)/mgx
+ ) # Line not starting with space
+ # (Next command's help)
+ {
+ print_help($1);
+ }
+ } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m)
+
+ # Help not found.
+ else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } ## end elsif ($cmd =~ /^h\s+(\S.*)$/)
+} ## end sub cmd_pre580_h
+
+=head2 Old C<W> command
+
+C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all.
+
+=cut
+
+sub cmd_pre580_W {
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Delete all watch expressions.
+ if ( $cmd =~ /^$/ ) {
+
+ # No watching is going on.
+ $trace &= ~2;
+
+ # Kill all the watch expressions and values.
+ @to_watch = @old_watch = ();
+ }
+
+ # Add a watch expression.
+ elsif ( $cmd =~ /^(.*)/s ) {
+
+ # add it to the list to be watched.
+ push @to_watch, $1;
+
+ # Get the current value of the expression.
+ # Doesn't handle expressions returning list values!
+ $evalarg = $1;
+ my ($val) = &eval;
+ $val = ( defined $val ) ? "'$val'" : 'undef';
+
+ # Save it.
+ push @old_watch, $val;
+
+ # We're watching stuff.
+ $trace |= 2;
+
+ } ## end elsif ($cmd =~ /^(.*)/s)
+} ## end sub cmd_pre580_W
+
+=head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS
+
+The debugger used to have a bunch of nearly-identical code to handle
+the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and
+C<cmd_prepost> unify all this into one set of code to handle the
+appropriate actions.
+
+=head2 C<cmd_pre590_prepost>
+
+A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't
+do something destructive. In pre 5.8 debuggers, the default action was to
+delete all the actions.
+
+=cut
+
+sub cmd_pre590_prepost {
+ my $cmd = shift;
+ my $line = shift || '*';
+ my $dbline = shift;
+
+ return &cmd_prepost( $cmd, $line, $dbline );
+} ## end sub cmd_pre590_prepost
+
+=head2 C<cmd_prepost>
+
+Actually does all the handling for C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc.
+Since the lists of actions are all held in arrays that are pointed to by
+references anyway, all we have to do is pick the right array reference and
+then use generic code to all, delete, or list actions.
+
+=cut
+
+sub cmd_prepost {
+ my $cmd = shift;
+
+ # No action supplied defaults to 'list'.
+ my $line = shift || '?';
+
+ # Figure out what to put in the prompt.
+ my $which = '';
+
+ # Make sure we have some array or another to address later.
+ # This means that if ssome reason the tests fail, we won't be
+ # trying to stash actions or delete them from the wrong place.
+ my $aref = [];
+
+ # < - Perl code to run before prompt.
+ if ( $cmd =~ /^\</o ) {
+ $which = 'pre-perl';
+ $aref = $pre;
+ }
+
+ # > - Perl code to run after prompt.
+ elsif ( $cmd =~ /^\>/o ) {
+ $which = 'post-perl';
+ $aref = $post;
+ }
+
+ # { - first check for properly-balanced braces.
+ elsif ( $cmd =~ /^\{/o ) {
+ if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) {
+ print $OUT
+"$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
+ }
+
+ # Properly balanced. Pre-prompt debugger actions.
+ else {
+ $which = 'pre-debugger';
+ $aref = $pretype;
+ }
+ } ## end elsif ( $cmd =~ /^\{/o )
+
+ # Did we find something that makes sense?
+ unless ($which) {
+ print $OUT "Confused by command: $cmd\n";
+ }
+
+ # Yes.
+ else {
+
+ # List actions.
+ if ( $line =~ /^\s*\?\s*$/o ) {
+ unless (@$aref) {
+
+ # Nothing there. Complain.
+ print $OUT "No $which actions.\n";
+ }
+ else {
+
+ # List the actions in the selected list.
+ print $OUT "$which commands:\n";
+ foreach my $action (@$aref) {
+ print $OUT "\t$cmd -- $action\n";
+ }
+ } ## end else
+ } ## end if ( $line =~ /^\s*\?\s*$/o)
+
+ # Might be a delete.
+ else {
+ if ( length($cmd) == 1 ) {
+ if ( $line =~ /^\s*\*\s*$/o ) {
+
+ # It's a delete. Get rid of the old actions in the
+ # selected list..
+ @$aref = ();
+ print $OUT "All $cmd actions cleared.\n";
+ }
+ else {
+
+ # Replace all the actions. (This is a <, >, or {).
+ @$aref = action($line);
+ }
+ } ## end if ( length($cmd) == 1)
+ elsif ( length($cmd) == 2 ) {
+
+ # Add the action to the line. (This is a <<, >>, or {{).
+ push @$aref, action($line);
+ }
+ else {
+
+ # <<<, >>>>, {{{{{{ ... something not a command.
+ print $OUT
+ "Confused by strange length of $which command($cmd)...\n";
+ }
+ } ## end else [ if ( $line =~ /^\s*\?\s*$/o)
+ } ## end else
+} ## end sub cmd_prepost
+
+=head1 C<DB::fake>
+
+Contains the C<at_exit> routine that the debugger uses to issue the
+C<Debugged program terminated ...> message after the program completes. See
+the C<END> block documentation for more details.
+
+=cut
+
+package DB::fake;
+
+sub at_exit {
+ "Debugged program terminated. Use `q' to quit or `R' to restart.";
+}
+
+package DB; # Do not trace this 1; below!
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/perllocal.pod b/Master/tlpkg/tlperl/lib/perllocal.pod
new file mode 100644
index 00000000000..feec6d0e2bf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/perllocal.pod
@@ -0,0 +1,110 @@
+=head2 Thu Feb 10 20:54:34 2011: C<Module> L<Win32::API|Win32::API>
+
+=over 4
+
+=item *
+
+C<installed into: x:\perlnew\site\lib>
+
+=item *
+
+C<LINKTYPE: dynamic>
+
+=item *
+
+C<VERSION: 0.59>
+
+=item *
+
+C<EXE_FILES: >
+
+=back
+
+=head2 Thu Feb 10 20:55:46 2011: C<Module> L<Win32::Shortcut|Win32::Shortcut>
+
+=over 4
+
+=item *
+
+C<installed into: x:\perlnew\site\lib>
+
+=item *
+
+C<LINKTYPE: dynamic>
+
+=item *
+
+C<VERSION: 0.07>
+
+=item *
+
+C<EXE_FILES: >
+
+=back
+
+=head2 Thu Feb 10 20:57:20 2011: C<Module> L<Win32API::Registry|Win32API::Registry>
+
+=over 4
+
+=item *
+
+C<installed into: x:\perlnew\site\lib>
+
+=item *
+
+C<LINKTYPE: dynamic>
+
+=item *
+
+C<VERSION: 0.32>
+
+=item *
+
+C<EXE_FILES: >
+
+=back
+
+=head2 Thu Feb 10 20:58:22 2011: C<Module> L<Win32::TieRegistry|Win32::TieRegistry>
+
+=over 4
+
+=item *
+
+C<installed into: x:\perlnew\site\lib>
+
+=item *
+
+C<LINKTYPE: dynamic>
+
+=item *
+
+C<VERSION: 0.26>
+
+=item *
+
+C<EXE_FILES: >
+
+=back
+
+=head2 Thu Feb 10 21:25:32 2011: C<Module> L<Tk|Tk>
+
+=over 4
+
+=item *
+
+C<installed into: x:\perlnew\site\lib>
+
+=item *
+
+C<LINKTYPE: dynamic>
+
+=item *
+
+C<VERSION: 804.029>
+
+=item *
+
+C<EXE_FILES: ptksh ptked gedi>
+
+=back
+
diff --git a/Master/tlpkg/tlperl/lib/pwd.pl b/Master/tlpkg/tlperl/lib/pwd.pl
new file mode 100644
index 00000000000..68b59fcc216
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/pwd.pl
@@ -0,0 +1,69 @@
+;# pwd.pl - keeps track of current working directory in PWD environment var
+;#
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Cwd
+
+;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
+;#
+;# $Log: pwd.pl,v $
+;#
+;# Usage:
+;# require "pwd.pl";
+;# &initpwd;
+;# ...
+;# &chdir($newdir);
+
+package pwd;
+
+sub main'initpwd {
+ if ($ENV{'PWD'}) {
+ local($dd,$di) = stat('.');
+ local($pd,$pi) = stat($ENV{'PWD'});
+ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
+ chop($ENV{'PWD'} = `pwd`);
+ }
+ }
+ else {
+ chop($ENV{'PWD'} = `pwd`);
+ }
+ if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
+ local($pd,$pi) = stat($2);
+ local($dd,$di) = stat($1);
+ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+}
+
+sub main'chdir {
+ local($newdir) = shift;
+ $newdir =~ s|/{2,}|/|g;
+ if (chdir $newdir) {
+ if ($newdir =~ m#^/#) {
+ $ENV{'PWD'} = $newdir;
+ }
+ else {
+ local(@curdir) = split(m#/#,$ENV{'PWD'});
+ @curdir = '' unless @curdir;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ }
+ else {
+ 0;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/re.pm b/Master/tlpkg/tlperl/lib/re.pm
new file mode 100644
index 00000000000..fb0b8d264c3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/re.pm
@@ -0,0 +1,485 @@
+package re;
+
+# pragma for controlling the regexp engine
+use strict;
+use warnings;
+
+our $VERSION = "0.11";
+our @ISA = qw(Exporter);
+our @EXPORT_OK = ('regmust',
+ qw(is_regexp regexp_pattern
+ regname regnames regnames_count));
+our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
+
+my %bitmask = (
+ taint => 0x00100000, # HINT_RE_TAINT
+ eval => 0x00200000, # HINT_RE_EVAL
+);
+
+sub setcolor {
+ eval { # Ignore errors
+ require Term::Cap;
+
+ my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
+ my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
+ my @props = split /,/, $props;
+ my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
+
+ $colors =~ s/\0//g;
+ $ENV{PERL_RE_COLORS} = $colors;
+ };
+ if ($@) {
+ $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
+ }
+
+}
+
+my %flags = (
+ COMPILE => 0x0000FF,
+ PARSE => 0x000001,
+ OPTIMISE => 0x000002,
+ TRIEC => 0x000004,
+ DUMP => 0x000008,
+ FLAGS => 0x000010,
+
+ EXECUTE => 0x00FF00,
+ INTUIT => 0x000100,
+ MATCH => 0x000200,
+ TRIEE => 0x000400,
+
+ EXTRA => 0xFF0000,
+ TRIEM => 0x010000,
+ OFFSETS => 0x020000,
+ OFFSETSDBG => 0x040000,
+ STATE => 0x080000,
+ OPTIMISEM => 0x100000,
+ STACK => 0x280000,
+ BUFFERS => 0x400000,
+ GPOS => 0x800000,
+);
+$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
+$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
+$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS};
+$flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
+$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
+$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
+
+if (defined &DynaLoader::boot_DynaLoader) {
+ require XSLoader;
+ XSLoader::load( __PACKAGE__, $VERSION);
+}
+# else we're miniperl
+# We need to work for miniperl, because the XS toolchain uses Text::Wrap, which
+# uses re 'taint'.
+
+sub _load_unload {
+ my ($on)= @_;
+ if ($on) {
+ # We call install() every time, as if we didn't, we wouldn't
+ # "see" any changes to the color environment var since
+ # the last time it was called.
+
+ # install() returns an integer, which if casted properly
+ # in C resolves to a structure containing the regexp
+ # hooks. Setting it to a random integer will guarantee
+ # segfaults.
+ $^H{regcomp} = install();
+ } else {
+ delete $^H{regcomp};
+ }
+}
+
+sub bits {
+ my $on = shift;
+ my $bits = 0;
+ unless (@_) {
+ require Carp;
+ Carp::carp("Useless use of \"re\" pragma");
+ }
+ foreach my $idx (0..$#_){
+ my $s=$_[$idx];
+ if ($s eq 'Debug' or $s eq 'Debugcolor') {
+ setcolor() if $s =~/color/i;
+ ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
+ for my $idx ($idx+1..$#_) {
+ if ($flags{$_[$idx]}) {
+ if ($on) {
+ ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
+ } else {
+ ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
+ }
+ } else {
+ require Carp;
+ Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
+ join(", ",sort keys %flags ) );
+ }
+ }
+ _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
+ last;
+ } elsif ($s eq 'debug' or $s eq 'debugcolor') {
+ setcolor() if $s =~/color/i;
+ _load_unload($on);
+ last;
+ } elsif (exists $bitmask{$s}) {
+ $bits |= $bitmask{$s};
+ } elsif ($EXPORT_OK{$s}) {
+ require Exporter;
+ re->export_to_level(2, 're', $s);
+ } else {
+ require Carp;
+ Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
+ join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
+ ")");
+ }
+ }
+ $bits;
+}
+
+sub import {
+ shift;
+ $^H |= bits(1, @_);
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ bits(0, @_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+re - Perl pragma to alter regular expression behaviour
+
+=head1 SYNOPSIS
+
+ use re 'taint';
+ ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here
+
+ $pat = '(?{ $foo = 1 })';
+ use re 'eval';
+ /foo${pat}bar/; # won't fail (when not under -T switch)
+
+ {
+ no re 'taint'; # the default
+ ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
+
+ no re 'eval'; # the default
+ /foo${pat}bar/; # disallowed (with or without -T switch)
+ }
+
+ use re 'debug'; # output debugging info during
+ /^(.*)$/s; # compile and run time
+
+
+ use re 'debugcolor'; # same as 'debug', but with colored output
+ ...
+
+ use re qw(Debug All); # Finer tuned debugging options.
+ use re qw(Debug More);
+ no re qw(Debug ALL); # Turn of all re debugging in this scope
+
+ use re qw(is_regexp regexp_pattern); # import utility functions
+ my ($pat,$mods)=regexp_pattern(qr/foo/i);
+ if (is_regexp($obj)) {
+ print "Got regexp: ",
+ scalar regexp_pattern($obj); # just as perl would stringify it
+ } # but no hassle with blessed re's.
+
+(We use $^X in these examples because it's tainted by default.)
+
+=head1 DESCRIPTION
+
+=head2 'taint' mode
+
+When C<use re 'taint'> is in effect, and a tainted string is the target
+of a regexp, the regexp memories (or values returned by the m// operator
+in list context) are tainted. This feature is useful when regexp operations
+on tainted data aren't meant to extract safe substrings, but to perform
+other transformations.
+
+=head2 'eval' mode
+
+When C<use re 'eval'> is in effect, a regexp is allowed to contain
+C<(?{ ... })> zero-width assertions and C<(??{ ... })> postponed
+subexpressions, even if the regular expression contains
+variable interpolation. That is normally disallowed, since it is a
+potential security risk. Note that this pragma is ignored when the regular
+expression is obtained from tainted data, i.e. evaluation is always
+disallowed with tainted regular expressions. See L<perlre/(?{ code })>
+and L<perlre/(??{ code })>.
+
+For the purpose of this pragma, interpolation of precompiled regular
+expressions (i.e., the result of C<qr//>) is I<not> considered variable
+interpolation. Thus:
+
+ /foo${pat}bar/
+
+I<is> allowed if $pat is a precompiled regular expression, even
+if $pat contains C<(?{ ... })> assertions or C<(??{ ... })> subexpressions.
+
+=head2 'debug' mode
+
+When C<use re 'debug'> is in effect, perl emits debugging messages when
+compiling and using regular expressions. The output is the same as that
+obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
+B<-Dr> switch. It may be quite voluminous depending on the complexity
+of the match. Using C<debugcolor> instead of C<debug> enables a
+form of output that can be used to get a colorful display on terminals
+that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a
+comma-separated list of C<termcap> properties to use for highlighting
+strings on/off, pre-point part on/off.
+See L<perldebug/"Debugging regular expressions"> for additional info.
+
+As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
+lexically scoped, as the other directives are. However they have both
+compile-time and run-time effects.
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=head2 'Debug' mode
+
+Similarly C<use re 'Debug'> produces debugging output, the difference
+being that it allows the fine tuning of what debugging output will be
+emitted. Options are divided into three groups, those related to
+compilation, those related to execution and those related to special
+purposes. The options are as follows:
+
+=over 4
+
+=item Compile related options
+
+=over 4
+
+=item COMPILE
+
+Turns on all compile related debug options.
+
+=item PARSE
+
+Turns on debug output related to the process of parsing the pattern.
+
+=item OPTIMISE
+
+Enables output related to the optimisation phase of compilation.
+
+=item TRIEC
+
+Detailed info about trie compilation.
+
+=item DUMP
+
+Dump the final program out after it is compiled and optimised.
+
+=back
+
+=item Execute related options
+
+=over 4
+
+=item EXECUTE
+
+Turns on all execute related debug options.
+
+=item MATCH
+
+Turns on debugging of the main matching loop.
+
+=item TRIEE
+
+Extra debugging of how tries execute.
+
+=item INTUIT
+
+Enable debugging of start point optimisations.
+
+=back
+
+=item Extra debugging options
+
+=over 4
+
+=item EXTRA
+
+Turns on all "extra" debugging options.
+
+=item BUFFERS
+
+Enable debugging the capture buffer storage during match. Warning,
+this can potentially produce extremely large output.
+
+=item TRIEM
+
+Enable enhanced TRIE debugging. Enhances both TRIEE
+and TRIEC.
+
+=item STATE
+
+Enable debugging of states in the engine.
+
+=item STACK
+
+Enable debugging of the recursion stack in the engine. Enabling
+or disabling this option automatically does the same for debugging
+states as well. This output from this can be quite large.
+
+=item OPTIMISEM
+
+Enable enhanced optimisation debugging and start point optimisations.
+Probably not useful except when debugging the regexp engine itself.
+
+=item OFFSETS
+
+Dump offset information. This can be used to see how regops correlate
+to the pattern. Output format is
+
+ NODENUM:POSITION[LENGTH]
+
+Where 1 is the position of the first char in the string. Note that position
+can be 0, or larger than the actual length of the pattern, likewise length
+can be zero.
+
+=item OFFSETSDBG
+
+Enable debugging of offsets information. This emits copious
+amounts of trace information and doesn't mesh well with other
+debug options.
+
+Almost definitely only useful to people hacking
+on the offsets part of the debug engine.
+
+=back
+
+=item Other useful flags
+
+These are useful shortcuts to save on the typing.
+
+=over 4
+
+=item ALL
+
+Enable all options at once except OFFSETS, OFFSETSDBG and BUFFERS
+
+=item All
+
+Enable DUMP and all execute options. Equivalent to:
+
+ use re 'debug';
+
+=item MORE
+
+=item More
+
+Enable TRIEM and all execute compile and execute options.
+
+=back
+
+=back
+
+As of 5.9.5 the directive C<use re 'debug'> and its equivalents are
+lexically scoped, as the other directives are. However they have both
+compile-time and run-time effects.
+
+=head2 Exportable Functions
+
+As of perl 5.9.5 're' debug contains a number of utility functions that
+may be optionally exported into the caller's namespace. They are listed
+below.
+
+=over 4
+
+=item is_regexp($ref)
+
+Returns true if the argument is a compiled regular expression as returned
+by C<qr//>, false if it is not.
+
+This function will not be confused by overloading or blessing. In
+internals terms, this extracts the regexp pointer out of the
+PERL_MAGIC_qr structure so it it cannot be fooled.
+
+=item regexp_pattern($ref)
+
+If the argument is a compiled regular expression as returned by C<qr//>,
+then this function returns the pattern.
+
+In list context it returns a two element list, the first element
+containing the pattern and the second containing the modifiers used when
+the pattern was compiled.
+
+ my ($pat, $mods) = regexp_pattern($ref);
+
+In scalar context it returns the same as perl would when stringifying a raw
+C<qr//> with the same pattern inside. If the argument is not a compiled
+reference then this routine returns false but defined in scalar context,
+and the empty list in list context. Thus the following
+
+ if (regexp_pattern($ref) eq '(?i-xsm:foo)')
+
+will be warning free regardless of what $ref actually is.
+
+Like C<is_regexp> this function will not be confused by overloading
+or blessing of the object.
+
+=item regmust($ref)
+
+If the argument is a compiled regular expression as returned by C<qr//>,
+then this function returns what the optimiser considers to be the longest
+anchored fixed string and longest floating fixed string in the pattern.
+
+A I<fixed string> is defined as being a substring that must appear for the
+pattern to match. An I<anchored fixed string> is a fixed string that must
+appear at a particular offset from the beginning of the match. A I<floating
+fixed string> is defined as a fixed string that can appear at any point in
+a range of positions relative to the start of the match. For example,
+
+ my $qr = qr/here .* there/x;
+ my ($anchored, $floating) = regmust($qr);
+ print "anchored:'$anchored'\nfloating:'$floating'\n";
+
+results in
+
+ anchored:'here'
+ floating:'there'
+
+Because the C<here> is before the C<.*> in the pattern, its position
+can be determined exactly. That's not true, however, for the C<there>;
+it could appear at any point after where the anchored string appeared.
+Perl uses both for its optimisations, prefering the longer, or, if they are
+equal, the floating.
+
+B<NOTE:> This may not necessarily be the definitive longest anchored and
+floating string. This will be what the optimiser of the Perl that you
+are using thinks is the longest. If you believe that the result is wrong
+please report it via the L<perlbug> utility.
+
+=item regname($name,$all)
+
+Returns the contents of a named buffer of the last successful match. If
+$all is true, then returns an array ref containing one entry per buffer,
+otherwise returns the first defined buffer.
+
+=item regnames($all)
+
+Returns a list of all of the named buffers defined in the last successful
+match. If $all is true, then it returns all names defined, if not it returns
+only names which were involved in the match.
+
+=item regnames_count()
+
+Returns the number of distinct names defined in the pattern used
+for the last successful match.
+
+B<Note:> this result is always the actual number of distinct
+named buffers defined, it may not actually match that which is
+returned by C<regnames()> and related routines when those routines
+have not been called with the $all parameter set.
+
+=back
+
+=head1 SEE ALSO
+
+L<perlmodlib/Pragmatic Modules>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/shellwords.pl b/Master/tlpkg/tlperl/lib/shellwords.pl
new file mode 100644
index 00000000000..b24ce963ad9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/shellwords.pl
@@ -0,0 +1,17 @@
+;# This legacy library is deprecated and will be removed in a future
+;# release of perl.
+;#
+;# shellwords.pl
+;#
+;# Usage:
+;# require 'shellwords.pl';
+;# @words = shellwords($line);
+;# or
+;# @words = shellwords(@lines);
+;# or
+;# @words = shellwords(); # defaults to $_ (and clobbers it)
+
+require Text::ParseWords;
+*shellwords = \&Text::ParseWords::old_shellwords;
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/sigtrap.pm b/Master/tlpkg/tlperl/lib/sigtrap.pm
new file mode 100644
index 00000000000..8577c728c78
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/sigtrap.pm
@@ -0,0 +1,289 @@
+package sigtrap;
+
+=head1 NAME
+
+sigtrap - Perl pragma to enable simple signal handling
+
+=cut
+
+use Carp;
+
+$VERSION = 1.04;
+$Verbose ||= 0;
+
+sub import {
+ my $pkg = shift;
+ my $handler = \&handler_traceback;
+ my $saw_sig = 0;
+ my $untrapped = 0;
+ local $_;
+
+ Arg_loop:
+ while (@_) {
+ $_ = shift;
+ if (/^[A-Z][A-Z0-9]*$/) {
+ $saw_sig++;
+ unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') {
+ print "Installing handler $handler for $_\n" if $Verbose;
+ $SIG{$_} = $handler;
+ }
+ }
+ elsif ($_ eq 'normal-signals') {
+ unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
+ }
+ elsif ($_ eq 'error-signals') {
+ unshift @_, grep(exists $SIG{$_},
+ qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
+ }
+ elsif ($_ eq 'old-interface-signals') {
+ unshift @_,
+ grep(exists $SIG{$_},
+ qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
+ }
+ elsif ($_ eq 'stack-trace') {
+ $handler = \&handler_traceback;
+ }
+ elsif ($_ eq 'die') {
+ $handler = \&handler_die;
+ }
+ elsif ($_ eq 'handler') {
+ @_ or croak "No argument specified after 'handler'";
+ $handler = shift;
+ unless (ref $handler or $handler eq 'IGNORE'
+ or $handler eq 'DEFAULT') {
+ require Symbol;
+ $handler = Symbol::qualify($handler, (caller)[0]);
+ }
+ }
+ elsif ($_ eq 'untrapped') {
+ $untrapped = 1;
+ }
+ elsif ($_ eq 'any') {
+ $untrapped = 0;
+ }
+ elsif ($_ =~ /^\d/) {
+ $VERSION >= $_ or croak "sigtrap.pm version $_ required,"
+ . " but this is only version $VERSION";
+ }
+ else {
+ croak "Unrecognized argument $_";
+ }
+ }
+ unless ($saw_sig) {
+ @_ = qw(old-interface-signals);
+ goto Arg_loop;
+ }
+}
+
+sub handler_die {
+ croak "Caught a SIG$_[0]";
+}
+
+sub handler_traceback {
+ package DB; # To get subroutine args.
+ $SIG{'ABRT'} = DEFAULT;
+ kill 'ABRT', $$ if $panic++;
+ syswrite(STDERR, 'Caught a SIG', 12);
+ syswrite(STDERR, $_[0], length($_[0]));
+ syswrite(STDERR, ' at ', 4);
+ ($pack,$file,$line) = caller;
+ syswrite(STDERR, $file, length($file));
+ syswrite(STDERR, ' line ', 6);
+ syswrite(STDERR, $line, length($line));
+ syswrite(STDERR, "\n", 1);
+
+ # Now go for broke.
+ for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
+ @a = ();
+ for (@args) {
+ s/([\'\\])/\\$1/g;
+ s/([^\0]*)/'$1'/
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ push(@a, $_);
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+ $e =~ s/[\\\']/\\$1/g if $e;
+ if ($r) {
+ $s = "require '$e'";
+ } elsif (defined $r) {
+ $s = "eval '$e'";
+ } elsif ($s eq '(eval)') {
+ $s = "eval {...}";
+ }
+ $f = "file `$f'" unless $f eq '-e';
+ $mess = "$w$s$a called from $f line $l\n";
+ syswrite(STDERR, $mess, length($mess));
+ }
+ kill 'ABRT', $$;
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use sigtrap;
+ use sigtrap qw(stack-trace old-interface-signals); # equivalent
+ use sigtrap qw(BUS SEGV PIPE ABRT);
+ use sigtrap qw(die INT QUIT);
+ use sigtrap qw(die normal-signals);
+ use sigtrap qw(die untrapped normal-signals);
+ use sigtrap qw(die untrapped normal-signals
+ stack-trace any error-signals);
+ use sigtrap 'handler' => \&my_handler, 'normal-signals';
+ use sigtrap qw(handler my_handler normal-signals
+ stack-trace error-signals);
+
+=head1 DESCRIPTION
+
+The B<sigtrap> pragma is a simple interface to installing signal
+handlers. You can have it install one of two handlers supplied by
+B<sigtrap> itself (one which provides a Perl stack trace and one which
+simply C<die()>s), or alternately you can supply your own handler for it
+to install. It can be told only to install a handler for signals which
+are either untrapped or ignored. It has a couple of lists of signals to
+trap, plus you can supply your own list of signals.
+
+The arguments passed to the C<use> statement which invokes B<sigtrap>
+are processed in order. When a signal name or the name of one of
+B<sigtrap>'s signal lists is encountered a handler is immediately
+installed, when an option is encountered it affects subsequently
+installed handlers.
+
+=head1 OPTIONS
+
+=head2 SIGNAL HANDLERS
+
+These options affect which handler will be used for subsequently
+installed signals.
+
+=over 4
+
+=item B<stack-trace>
+
+The handler used for subsequently installed signals outputs a Perl stack
+trace to STDERR and then tries to dump core. This is the default signal
+handler.
+
+=item B<die>
+
+The handler used for subsequently installed signals calls C<die>
+(actually C<croak>) with a message indicating which signal was caught.
+
+=item B<handler> I<your-handler>
+
+I<your-handler> will be used as the handler for subsequently installed
+signals. I<your-handler> can be any value which is valid as an
+assignment to an element of C<%SIG>. See L<perlvar> for examples of
+handler functions.
+
+=back
+
+=head2 SIGNAL LISTS
+
+B<sigtrap> has a few built-in lists of signals to trap. They are:
+
+=over 4
+
+=item B<normal-signals>
+
+These are the signals which a program might normally expect to encounter
+and which by default cause it to terminate. They are HUP, INT, PIPE and
+TERM.
+
+=item B<error-signals>
+
+These signals usually indicate a serious problem with the Perl
+interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL,
+QUIT, SEGV, SYS and TRAP.
+
+=item B<old-interface-signals>
+
+These are the signals which were trapped by default by the old
+B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
+SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to
+B<sigtrap>, this list is used.
+
+=back
+
+For each of these three lists, the collection of signals set to be
+trapped is checked before trapping; if your architecture does not
+implement a particular signal, it will not be trapped but rather
+silently ignored.
+
+=head2 OTHER
+
+=over 4
+
+=item B<untrapped>
+
+This token tells B<sigtrap> to install handlers only for subsequently
+listed signals which aren't already trapped or ignored.
+
+=item B<any>
+
+This token tells B<sigtrap> to install handlers for all subsequently
+listed signals. This is the default behavior.
+
+=item I<signal>
+
+Any argument which looks like a signal name (that is,
+C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
+handler for that name.
+
+=item I<number>
+
+Require that at least version I<number> of B<sigtrap> is being used.
+
+=back
+
+=head1 EXAMPLES
+
+Provide a stack trace for the old-interface-signals:
+
+ use sigtrap;
+
+Ditto:
+
+ use sigtrap qw(stack-trace old-interface-signals);
+
+Provide a stack trace on the 4 listed signals only:
+
+ use sigtrap qw(BUS SEGV PIPE ABRT);
+
+Die on INT or QUIT:
+
+ use sigtrap qw(die INT QUIT);
+
+Die on HUP, INT, PIPE or TERM:
+
+ use sigtrap qw(die normal-signals);
+
+Die on HUP, INT, PIPE or TERM, except don't change the behavior for
+signals which are already trapped or ignored:
+
+ use sigtrap qw(die untrapped normal-signals);
+
+Die on receipt one of an of the B<normal-signals> which is currently
+B<untrapped>, provide a stack trace on receipt of B<any> of the
+B<error-signals>:
+
+ use sigtrap qw(die untrapped normal-signals
+ stack-trace any error-signals);
+
+Install my_handler() as the handler for the B<normal-signals>:
+
+ use sigtrap 'handler', \&my_handler, 'normal-signals';
+
+Install my_handler() as the handler for the normal-signals, provide a
+Perl stack trace on receipt of one of the error-signals:
+
+ use sigtrap qw(handler my_handler normal-signals
+ stack-trace error-signals);
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/sort.pm b/Master/tlpkg/tlperl/lib/sort.pm
new file mode 100644
index 00000000000..922f82b4691
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/sort.pm
@@ -0,0 +1,196 @@
+package sort;
+
+our $VERSION = '2.01';
+
+# The hints for pp_sort are now stored in $^H{sort}; older versions
+# of perl used the global variable $sort::hints. -- rjh 2005-12-19
+
+$sort::quicksort_bit = 0x00000001;
+$sort::mergesort_bit = 0x00000002;
+$sort::sort_bits = 0x000000FF; # allow 256 different ones
+$sort::stable_bit = 0x00000100;
+
+use strict;
+
+sub import {
+ shift;
+ if (@_ == 0) {
+ require Carp;
+ Carp::croak("sort pragma requires arguments");
+ }
+ local $_;
+ $^H{sort} //= 0;
+ while ($_ = shift(@_)) {
+ if (/^_q(?:uick)?sort$/) {
+ $^H{sort} &= ~$sort::sort_bits;
+ $^H{sort} |= $sort::quicksort_bit;
+ } elsif ($_ eq '_mergesort') {
+ $^H{sort} &= ~$sort::sort_bits;
+ $^H{sort} |= $sort::mergesort_bit;
+ } elsif ($_ eq 'stable') {
+ $^H{sort} |= $sort::stable_bit;
+ } elsif ($_ eq 'defaults') {
+ $^H{sort} = 0;
+ } else {
+ require Carp;
+ Carp::croak("sort: unknown subpragma '$_'");
+ }
+ }
+}
+
+sub unimport {
+ shift;
+ if (@_ == 0) {
+ require Carp;
+ Carp::croak("sort pragma requires arguments");
+ }
+ local $_;
+ no warnings 'uninitialized'; # bitops would warn
+ while ($_ = shift(@_)) {
+ if (/^_q(?:uick)?sort$/) {
+ $^H{sort} &= ~$sort::sort_bits;
+ } elsif ($_ eq '_mergesort') {
+ $^H{sort} &= ~$sort::sort_bits;
+ } elsif ($_ eq 'stable') {
+ $^H{sort} &= ~$sort::stable_bit;
+ } else {
+ require Carp;
+ Carp::croak("sort: unknown subpragma '$_'");
+ }
+ }
+}
+
+sub current {
+ my @sort;
+ if ($^H{sort}) {
+ push @sort, 'quicksort' if $^H{sort} & $sort::quicksort_bit;
+ push @sort, 'mergesort' if $^H{sort} & $sort::mergesort_bit;
+ push @sort, 'stable' if $^H{sort} & $sort::stable_bit;
+ }
+ push @sort, 'mergesort' unless @sort;
+ join(' ', @sort);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+sort - perl pragma to control sort() behaviour
+
+=head1 SYNOPSIS
+
+ use sort 'stable'; # guarantee stability
+ use sort '_quicksort'; # use a quicksort algorithm
+ use sort '_mergesort'; # use a mergesort algorithm
+ use sort 'defaults'; # revert to default behavior
+ no sort 'stable'; # stability not important
+
+ use sort '_qsort'; # alias for quicksort
+
+ my $current;
+ BEGIN {
+ $current = sort::current(); # identify prevailing algorithm
+ }
+
+=head1 DESCRIPTION
+
+With the C<sort> pragma you can control the behaviour of the builtin
+C<sort()> function.
+
+In Perl versions 5.6 and earlier the quicksort algorithm was used to
+implement C<sort()>, but in Perl 5.8 a mergesort algorithm was also made
+available, mainly to guarantee worst case O(N log N) behaviour:
+the worst case of quicksort is O(N**2). In Perl 5.8 and later,
+quicksort defends against quadratic behaviour by shuffling large
+arrays before sorting.
+
+A stable sort means that for records that compare equal, the original
+input ordering is preserved. Mergesort is stable, quicksort is not.
+Stability will matter only if elements that compare equal can be
+distinguished in some other way. That means that simple numerical
+and lexical sorts do not profit from stability, since equal elements
+are indistinguishable. However, with a comparison such as
+
+ { substr($a, 0, 3) cmp substr($b, 0, 3) }
+
+stability might matter because elements that compare equal on the
+first 3 characters may be distinguished based on subsequent characters.
+In Perl 5.8 and later, quicksort can be stabilized, but doing so will
+add overhead, so it should only be done if it matters.
+
+The best algorithm depends on many things. On average, mergesort
+does fewer comparisons than quicksort, so it may be better when
+complicated comparison routines are used. Mergesort also takes
+advantage of pre-existing order, so it would be favored for using
+C<sort()> to merge several sorted arrays. On the other hand, quicksort
+is often faster for small arrays, and on arrays of a few distinct
+values, repeated many times. You can force the
+choice of algorithm with this pragma, but this feels heavy-handed,
+so the subpragmas beginning with a C<_> may not persist beyond Perl 5.8.
+The default algorithm is mergesort, which will be stable even if
+you do not explicitly demand it.
+But the stability of the default sort is a side-effect that could
+change in later versions. If stability is important, be sure to
+say so with a
+
+ use sort 'stable';
+
+The C<no sort> pragma doesn't
+I<forbid> what follows, it just leaves the choice open. Thus, after
+
+ no sort qw(_mergesort stable);
+
+a mergesort, which happens to be stable, will be employed anyway.
+Note that
+
+ no sort "_quicksort";
+ no sort "_mergesort";
+
+have exactly the same effect, leaving the choice of sort algorithm open.
+
+=head1 CAVEATS
+
+As of Perl 5.10, this pragma is lexically scoped and takes effect
+at compile time. In earlier versions its effect was global and took
+effect at run-time; the documentation suggested using C<eval()> to
+change the behaviour:
+
+ { eval 'use sort qw(defaults _quicksort)'; # force quicksort
+ eval 'no sort "stable"'; # stability not wanted
+ print sort::current . "\n";
+ @a = sort @b;
+ eval 'use sort "defaults"'; # clean up, for others
+ }
+ { eval 'use sort qw(defaults stable)'; # force stability
+ print sort::current . "\n";
+ @c = sort @d;
+ eval 'use sort "defaults"'; # clean up, for others
+ }
+
+Such code no longer has the desired effect, for two reasons.
+Firstly, the use of C<eval()> means that the sorting algorithm
+is not changed until runtime, by which time it's too late to
+have any effect. Secondly, C<sort::current> is also called at
+run-time, when in fact the compile-time value of C<sort::current>
+is the one that matters.
+
+So now this code would be written:
+
+ { use sort qw(defaults _quicksort); # force quicksort
+ no sort "stable"; # stability not wanted
+ my $current;
+ BEGIN { $current = print sort::current; }
+ print "$current\n";
+ @a = sort @b;
+ # Pragmas go out of scope at the end of the block
+ }
+ { use sort qw(defaults stable); # force stability
+ my $current;
+ BEGIN { $current = print sort::current; }
+ print "$current\n";
+ @c = sort @d;
+ }
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/stat.pl b/Master/tlpkg/tlperl/lib/stat.pl
new file mode 100644
index 00000000000..4174d6007d1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/stat.pl
@@ -0,0 +1,33 @@
+;# This legacy library is deprecated and will be removed in a future
+;# release of perl.
+;#
+;# Usage:
+;# require 'stat.pl';
+;# @ary = stat(foo);
+;# $st_dev = @ary[$ST_DEV];
+;#
+
+$ST_DEV = 0 + $[;
+$ST_INO = 1 + $[;
+$ST_MODE = 2 + $[;
+$ST_NLINK = 3 + $[;
+$ST_UID = 4 + $[;
+$ST_GID = 5 + $[;
+$ST_RDEV = 6 + $[;
+$ST_SIZE = 7 + $[;
+$ST_ATIME = 8 + $[;
+$ST_MTIME = 9 + $[;
+$ST_CTIME = 10 + $[;
+$ST_BLKSIZE = 11 + $[;
+$ST_BLOCKS = 12 + $[;
+
+;# Usage:
+;# require 'stat.pl';
+;# do Stat('foo'); # sets st_* as a side effect
+;#
+sub Stat {
+ ($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) = stat(shift(@_));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/strict.pm b/Master/tlpkg/tlperl/lib/strict.pm
new file mode 100644
index 00000000000..053aae75012
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/strict.pm
@@ -0,0 +1,147 @@
+package strict;
+
+$strict::VERSION = "1.04";
+
+# Verify that we're called correctly so that strictures will work.
+unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
+ # Can't use Carp, since Carp uses us!
+ my (undef, $f, $l) = caller;
+ die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
+}
+
+my %bitmask = (
+refs => 0x00000002,
+subs => 0x00000200,
+vars => 0x00000400
+);
+
+sub bits {
+ my $bits = 0;
+ my @wrong;
+ foreach my $s (@_) {
+ push @wrong, $s unless exists $bitmask{$s};
+ $bits |= $bitmask{$s} || 0;
+ }
+ if (@wrong) {
+ require Carp;
+ Carp::croak("Unknown 'strict' tag(s) '@wrong'");
+ }
+ $bits;
+}
+
+my $default_bits = bits(qw(refs subs vars));
+
+sub import {
+ shift;
+ $^H |= @_ ? bits(@_) : $default_bits;
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ (@_ ? bits(@_) : $default_bits);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+strict - Perl pragma to restrict unsafe constructs
+
+=head1 SYNOPSIS
+
+ use strict;
+
+ use strict "vars";
+ use strict "refs";
+ use strict "subs";
+
+ use strict;
+ no strict "vars";
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible restrictions are assumed.
+(This is the safest mode to operate in, but is sometimes too strict for
+casual programming.) Currently, there are three possible things to be
+strict about: "subs", "vars", and "refs".
+
+=over 6
+
+=item C<strict refs>
+
+This generates a runtime error if you
+use symbolic references (see L<perlref>).
+
+ use strict 'refs';
+ $ref = \$foo;
+ print $$ref; # ok
+ $ref = "foo";
+ print $$ref; # runtime error; normally ok
+ $file = "STDOUT";
+ print $file "Hi!"; # error; note: no comma after $file
+
+There is one exception to this rule:
+
+ $bar = \&{'foo'};
+ &$bar;
+
+is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
+
+
+=item C<strict vars>
+
+This generates a compile-time error if you access a variable that wasn't
+declared via C<our> or C<use vars>,
+localized via C<my()>, or wasn't fully qualified. Because this is to avoid
+variable suicide problems and subtle dynamic scoping issues, a merely
+local() variable isn't good enough. See L<perlfunc/my> and
+L<perlfunc/local>.
+
+ use strict 'vars';
+ $X::foo = 1; # ok, fully qualified
+ my $foo = 10; # ok, my() var
+ local $foo = 9; # blows up
+
+ package Cinna;
+ our $bar; # Declares $bar in current package
+ $bar = 'HgS'; # ok, global declared via pragma
+
+The local() generated a compile-time error because you just touched a global
+name without fully qualifying it.
+
+Because of their special use by sort(), the variables $a and $b are
+exempted from this check.
+
+=item C<strict subs>
+
+This disables the poetry optimization, generating a compile-time error if
+you try to use a bareword identifier that's not a subroutine, unless it
+is a simple identifier (no colons) and that it appears in curly braces or
+on the left hand side of the C<< => >> symbol.
+
+ use strict 'subs';
+ $SIG{PIPE} = Plumber; # blows up
+ $SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok
+ $SIG{PIPE} = \&Plumber; # preferred form
+
+=back
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=head1 HISTORY
+
+C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted
+compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or
+inside curlies), but without forcing it always to a literal string.
+
+Starting with Perl 5.8.1 strict is strict about its restrictions:
+if unknown restrictions are used, the strict pragma will abort with
+
+ Unknown 'strict' tag(s) '...'
+
+As of version 1.04 (Perl 5.10), strict verifies that it is used as
+"strict" to avoid the dreaded Strict trap on case insensitive file
+systems.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/subs.pm b/Master/tlpkg/tlperl/lib/subs.pm
new file mode 100644
index 00000000000..e5a9aa8827d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/subs.pm
@@ -0,0 +1,40 @@
+package subs;
+
+our $VERSION = '1.00';
+
+=head1 NAME
+
+subs - Perl pragma to predeclare sub names
+
+=head1 SYNOPSIS
+
+ use subs qw(frob);
+ frob 3..10;
+
+=head1 DESCRIPTION
+
+This will predeclare all the subroutine whose names are
+in the list, allowing you to use them without parentheses
+even before they're declared.
+
+Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
+C<use subs> declarations are not BLOCK-scoped. They are thus effective
+for the entire file in which they appear. You may not rescind such
+declarations with C<no vars> or C<no subs>.
+
+See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>.
+
+=cut
+
+require 5.000;
+
+sub import {
+ my $callpack = caller;
+ my $pack = shift;
+ my @imports = @_;
+ foreach $sym (@imports) {
+ *{"${callpack}::$sym"} = \&{"${callpack}::$sym"};
+ }
+};
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/syslog.pl b/Master/tlpkg/tlperl/lib/syslog.pl
new file mode 100644
index 00000000000..f0dbb1c96a2
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/syslog.pl
@@ -0,0 +1,199 @@
+#
+# syslog.pl
+#
+# $Log: syslog.pl,v $
+#
+# tom christiansen <tchrist@convex.com>
+# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
+# NOTE: openlog now takes three arguments, just like openlog(3)
+#
+# call syslog() with a string priority and a list of printf() args
+# like syslog(3)
+#
+# usage: require 'syslog.pl';
+#
+# then (put these all in a script to test function)
+#
+#
+# do openlog($program,'cons,pid','user');
+# do syslog('info','this is another test');
+# do syslog('mail|warning','this is a better test: %d', time);
+# do closelog();
+#
+# do syslog('debug','this is the last test');
+# do openlog("$program $$",'ndelay','user');
+# do syslog('notice','fooprogram: this is really done');
+#
+# $! = 55;
+# do syslog('info','problem was %m'); # %m == $! in syslog(3)
+
+package syslog;
+
+use warnings::register;
+
+$host = 'localhost' unless $host; # set $syslog'host to change
+
+if ($] >= 5 && warnings::enabled()) {
+ warnings::warn("You should 'use Sys::Syslog' instead; continuing");
+}
+
+require 'syslog.ph';
+
+ eval 'use Socket; 1' ||
+ eval { require "socket.ph" } ||
+ require "sys/socket.ph";
+
+$maskpri = &LOG_UPTO(&LOG_DEBUG);
+
+sub main'openlog {
+ ($ident, $logopt, $facility) = @_; # package vars
+ $lo_pid = $logopt =~ /\bpid\b/;
+ $lo_ndelay = $logopt =~ /\bndelay\b/;
+ $lo_cons = $logopt =~ /\bcons\b/;
+ $lo_nowait = $logopt =~ /\bnowait\b/;
+ &connect if $lo_ndelay;
+}
+
+sub main'closelog {
+ $facility = $ident = '';
+ &disconnect;
+}
+
+sub main'setlogmask {
+ local($oldmask) = $maskpri;
+ $maskpri = shift;
+ $oldmask;
+}
+
+sub main'syslog {
+ local($priority) = shift;
+ local($mask) = shift;
+ local($message, $whoami);
+ local(@words, $num, $numpri, $numfac, $sum);
+ local($facility) = $facility; # may need to change temporarily.
+
+ die "syslog: expected both priority and mask" unless $mask && $priority;
+
+ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
+ foreach (@words) {
+ $num = &xlate($_); # Translate word to number.
+ if (/^kern$/ || $num < 0) {
+ die "syslog: invalid level/facility: $_\n";
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ die "syslog: too many levels given: $_\n" if defined($numpri);
+ $numpri = $num;
+ return 0 unless &LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ die "syslog: too many facilities given: $_\n" if defined($numfac);
+ $facility = $_;
+ $numfac = $num;
+ }
+ }
+
+ die "syslog: level must be given\n" unless defined($numpri);
+
+ if (!defined($numfac)) { # Facility not specified in this call.
+ $facility = 'user' unless $facility;
+ $numfac = &xlate($facility);
+ }
+
+ &connect unless $connected;
+
+ $whoami = $ident;
+
+ if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
+ $whoami = $1;
+ $mask = $2;
+ }
+
+ unless ($whoami) {
+ ($whoami = getlogin) ||
+ ($whoami = getpwuid($<)) ||
+ ($whoami = 'syslog');
+ }
+
+ $whoami .= "[$$]" if $lo_pid;
+
+ $mask =~ s/%m/$!/g;
+ $mask .= "\n" unless $mask =~ /\n$/;
+ $message = sprintf ($mask, @_);
+
+ $sum = $numpri + $numfac;
+ unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
+ if ($lo_cons) {
+ if ($pid = fork) {
+ unless ($lo_nowait) {
+ do {$died = wait;} until $died == $pid || $died < 0;
+ }
+ }
+ else {
+ open(CONS,">/dev/console");
+ print CONS "<$facility.$priority>$whoami: $message\r";
+ exit if defined $pid; # if fork failed, we're parent
+ close CONS;
+ }
+ }
+ }
+}
+
+sub xlate {
+ local($name) = @_;
+ $name = uc $name;
+ $name = "LOG_$name" unless $name =~ /^LOG_/;
+ $name = "syslog'$name";
+ defined &$name ? &$name : -1;
+}
+
+sub connect {
+ $pat = 'S n C4 x8';
+
+ $af_unix = &AF_UNIX;
+ $af_inet = &AF_INET;
+
+ $stream = &SOCK_STREAM;
+ $datagram = &SOCK_DGRAM;
+
+ ($name,$aliases,$proto) = getprotobyname('udp');
+ $udp = $proto;
+
+ ($name,$aliases,$port,$proto) = getservbyname('syslog','udp');
+ $syslog = $port;
+
+ if (chop($myname = `hostname`)) {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
+ die "Can't lookup $myname\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ else {
+ @bytes = (0,0,0,0);
+ }
+ $this = pack($pat, $af_inet, 0, @bytes);
+
+ if ($host =~ /^\d+\./) {
+ @bytes = split(/\./,$host);
+ }
+ else {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
+ die "Can't lookup $host\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ $that = pack($pat,$af_inet,$syslog,@bytes);
+
+ socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
+ bind(SYSLOG,$this) || die "bind: $!\n";
+ connect(SYSLOG,$that) || die "connect: $!\n";
+
+ local($old) = select(SYSLOG); $| = 1; select($old);
+ $connected = 1;
+}
+
+sub disconnect {
+ close SYSLOG;
+ $connected = 0;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/tainted.pl b/Master/tlpkg/tlperl/lib/tainted.pl
new file mode 100644
index 00000000000..a3a560ffecc
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/tainted.pl
@@ -0,0 +1,12 @@
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+# This subroutine returns true if its argument is tainted, false otherwise.
+#
+
+sub tainted {
+ local($@);
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/termcap.pl b/Master/tlpkg/tlperl/lib/termcap.pl
new file mode 100644
index 00000000000..247a1718da7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/termcap.pl
@@ -0,0 +1,181 @@
+;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
+#
+# This library is no longer being maintained, and is included for backward
+# compatibility with Perl 4 programs which may require it.
+# This legacy library is deprecated and will be removed in a future
+# release of perl.
+#
+# In particular, this should not be used as an example of modern Perl
+# programming techniques.
+#
+# Suggested alternative: Term::Cap
+#
+
+;#
+;# Usage:
+;# require 'ioctl.pl';
+;# ioctl(TTY,$TIOCGETP,$foo);
+;# ($ispeed,$ospeed) = unpack('cc',$foo);
+;# require 'termcap.pl';
+;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
+;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
+;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+;#
+sub Tgetent {
+ local($TERM) = @_;
+ local($TERMCAP,$_,$entry,$loop,$field);
+
+ # warn "Tgetent: no ospeed set" unless $ospeed;
+ foreach $key (keys %TC) {
+ delete $TC{$key};
+ }
+ $TERM = $ENV{'TERM'} unless $TERM;
+ $TERM =~ s/(\W)/\\$1/g;
+ $TERMCAP = $ENV{'TERMCAP'};
+ $TERMCAP = '/etc/termcap' unless $TERMCAP;
+ if ($TERMCAP !~ m:^/:) {
+ if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
+ $TERMCAP = '/etc/termcap';
+ }
+ }
+ if ($TERMCAP =~ m:^/:) {
+ $entry = '';
+ do {
+ $loop = "
+ open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
+ while (<TERMCAP>) {
+ next if /^#/;
+ next if /^\t/;
+ if (/(^|\\|)${TERM}[:\\|]/) {
+ chop;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ chop;
+ }
+ \$_ .= ':';
+ last;
+ }
+ }
+ close TERMCAP;
+ \$entry .= \$_;
+ ";
+ eval $loop;
+ } while s/:tc=([^:]+):/:/ && ($TERM = $1);
+ $TERMCAP = $entry;
+ }
+
+ foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+ if ($field =~ /^\w\w$/) {
+ $TC{$field} = 1;
+ }
+ elsif ($field =~ /^(\w\w)#(.*)/) {
+ $TC{$1} = $2 if $TC{$1} eq '';
+ }
+ elsif ($field =~ /^(\w\w)=(.*)/) {
+ $entry = $1;
+ $_ = $2;
+ s/\\E/\033/g;
+ s/\\(200)/pack('c',0)/eg; # NUL character
+ s/\\(0\d\d)/pack('c',oct($1))/eg; # octal
+ s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex
+ s/\\(\d\d\d)/pack('c',$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;
+ $TC{$entry} = $_ if $TC{$entry} eq '';
+ }
+ }
+ $TC{'pc'} = "\0" if $TC{'pc'} eq '';
+ $TC{'bc'} = "\b" if $TC{'bc'} eq '';
+}
+
+@Tputs = (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);
+
+sub Tputs {
+ local($string,$affcnt,$FH) = @_;
+ local($ms);
+ if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
+ $ms = $1;
+ $ms *= $affcnt if $2;
+ $string = $3;
+ $decr = $Tputs[$ospeed];
+ if ($decr > .1) {
+ $ms += $decr / 2;
+ $string .= $TC{'pc'} x ($ms / $decr);
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+sub Tgoto {
+ local($string) = shift(@_);
+ local($result) = '';
+ local($after) = '';
+ local($code,$tmp) = @_;
+ local(@tmp);
+ @tmp = ($tmp,$code);
+ local($online) = 0;
+ 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 .= $TC{'up'} if $TC{'up'};
+ }
+ else {
+ ++$tmp, $after .= $TC{'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";
+ }
+ }
+ $result . $string . $after;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/threads.pm b/Master/tlpkg/tlperl/lib/threads.pm
new file mode 100644
index 00000000000..4552e50959b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/threads.pm
@@ -0,0 +1,1066 @@
+package threads;
+
+use 5.008;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.75';
+my $XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+# Verify this Perl supports threads
+require Config;
+if (! $Config::Config{useithreads}) {
+ die("This Perl not built to support threads\n");
+}
+
+# Complain if 'threads' is loaded after 'threads::shared'
+if ($threads::shared::threads_shared) {
+ warn <<'_MSG_';
+Warning, threads::shared has already been loaded. To
+enable shared variables, 'use threads' must be called
+before threads::shared or any module that uses it.
+_MSG_
+}
+
+# Declare that we have been loaded
+$threads::threads = 1;
+
+# Load the XS code
+require XSLoader;
+XSLoader::load('threads', $XS_VERSION);
+
+
+### Export ###
+
+sub import
+{
+ my $class = shift; # Not used
+
+ # Exported subroutines
+ my @EXPORT = qw(async);
+
+ # Handle args
+ while (my $sym = shift) {
+ if ($sym =~ /^(?:stack|exit)/i) {
+ if (defined(my $arg = shift)) {
+ if ($sym =~ /^stack/i) {
+ threads->set_stack_size($arg);
+ } else {
+ $threads::thread_exit_only = $arg =~ /^thread/i;
+ }
+ } else {
+ require Carp;
+ Carp::croak("threads: Missing argument for option: $sym");
+ }
+
+ } elsif ($sym =~ /^str/i) {
+ import overload ('""' => \&tid);
+
+ } elsif ($sym =~ /^(?::all|yield)$/) {
+ push(@EXPORT, qw(yield));
+
+ } else {
+ require Carp;
+ Carp::croak("threads: Unknown import option: $sym");
+ }
+ }
+
+ # Export subroutine names
+ my $caller = caller();
+ foreach my $sym (@EXPORT) {
+ no strict 'refs';
+ *{$caller.'::'.$sym} = \&{$sym};
+ }
+
+ # Set stack size via environment variable
+ if (exists($ENV{'PERL5_ITHREADS_STACK_SIZE'})) {
+ threads->set_stack_size($ENV{'PERL5_ITHREADS_STACK_SIZE'});
+ }
+}
+
+
+### Methods, etc. ###
+
+# Exit from a thread (only)
+sub exit
+{
+ my ($class, $status) = @_;
+ if (! defined($status)) {
+ $status = 0;
+ }
+
+ # Class method only
+ if (ref($class)) {
+ require Carp;
+ Carp::croak('Usage: threads->exit(status)');
+ }
+
+ $class->set_thread_exit_only(1);
+ CORE::exit($status);
+}
+
+# 'Constant' args for threads->list()
+sub threads::all { }
+sub threads::running { 1 }
+sub threads::joinable { 0 }
+
+# 'new' is an alias for 'create'
+*new = \&create;
+
+# 'async' is a function alias for the 'threads->create()' method
+sub async (&;@)
+{
+ unshift(@_, 'threads');
+ # Use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2)
+ goto &create;
+}
+
+# Thread object equality checking
+use overload (
+ '==' => \&equal,
+ '!=' => sub { ! equal(@_) },
+ 'fallback' => 1
+);
+
+1;
+
+__END__
+
+=head1 NAME
+
+threads - Perl interpreter-based threads
+
+=head1 VERSION
+
+This document describes threads version 1.75
+
+=head1 SYNOPSIS
+
+ use threads ('yield',
+ 'stack_size' => 64*4096,
+ 'exit' => 'threads_only',
+ 'stringify');
+
+ sub start_thread {
+ my @args = @_;
+ print('Thread started: ', join(' ', @args), "\n");
+ }
+ my $thr = threads->create('start_thread', 'argument');
+ $thr->join();
+
+ threads->create(sub { print("I am a thread\n"); })->join();
+
+ my $thr2 = async { foreach (@files) { ... } };
+ $thr2->join();
+ if (my $err = $thr2->error()) {
+ warn("Thread error: $err\n");
+ }
+
+ # Invoke thread in list context (implicit) so it can return a list
+ my ($thr) = threads->create(sub { return (qw/a b c/); });
+ # or specify list context explicitly
+ my $thr = threads->create({'context' => 'list'},
+ sub { return (qw/a b c/); });
+ my @results = $thr->join();
+
+ $thr->detach();
+
+ # Get a thread's object
+ $thr = threads->self();
+ $thr = threads->object($tid);
+
+ # Get a thread's ID
+ $tid = threads->tid();
+ $tid = $thr->tid();
+ $tid = "$thr";
+
+ # Give other threads a chance to run
+ threads->yield();
+ yield();
+
+ # Lists of non-detached threads
+ my @threads = threads->list();
+ my $thread_count = threads->list();
+
+ my @running = threads->list(threads::running);
+ my @joinable = threads->list(threads::joinable);
+
+ # Test thread objects
+ if ($thr1 == $thr2) {
+ ...
+ }
+
+ # Manage thread stack size
+ $stack_size = threads->get_stack_size();
+ $old_size = threads->set_stack_size(32*4096);
+
+ # Create a thread with a specific context and stack size
+ my $thr = threads->create({ 'context' => 'list',
+ 'stack_size' => 32*4096,
+ 'exit' => 'thread_only' },
+ \&foo);
+
+ # Get thread's context
+ my $wantarray = $thr->wantarray();
+
+ # Check thread's state
+ if ($thr->is_running()) {
+ sleep(1);
+ }
+ if ($thr->is_joinable()) {
+ $thr->join();
+ }
+
+ # Send a signal to a thread
+ $thr->kill('SIGUSR1');
+
+ # Exit a thread
+ threads->exit();
+
+=head1 DESCRIPTION
+
+Since Perl 5.8, thread programming has been available using a model called
+I<interpreter threads> which provides a new Perl interpreter for each
+thread, and, by default, results in no data or state information being shared
+between threads.
+
+(Prior to Perl 5.8, I<5005threads> was available through the C<Thread.pm> API.
+This threading model has been deprecated, and was removed as of Perl 5.10.0.)
+
+As just mentioned, all variables are, by default, thread local. To use shared
+variables, you need to also load L<threads::shared>:
+
+ use threads;
+ use threads::shared;
+
+When loading L<threads::shared>, you must C<use threads> before you
+C<use threads::shared>. (C<threads> will emit a warning if you do it the
+other way around.)
+
+It is strongly recommended that you enable threads via C<use threads> as early
+as possible in your script.
+
+If needed, scripts can be written so as to run on both threaded and
+non-threaded Perls:
+
+ my $can_use_threads = eval 'use threads; 1';
+ if ($can_use_threads) {
+ # Do processing using threads
+ ...
+ } else {
+ # Do it without using threads
+ ...
+ }
+
+=over
+
+=item $thr = threads->create(FUNCTION, ARGS)
+
+This will create a new thread that will begin execution with the specified
+entry point function, and give it the I<ARGS> list as parameters. It will
+return the corresponding threads object, or C<undef> if thread creation failed.
+
+I<FUNCTION> may either be the name of a function, an anonymous subroutine, or
+a code ref.
+
+ my $thr = threads->create('func_name', ...);
+ # or
+ my $thr = threads->create(sub { ... }, ...);
+ # or
+ my $thr = threads->create(\&func, ...);
+
+The C<-E<gt>new()> method is an alias for C<-E<gt>create()>.
+
+=item $thr->join()
+
+This will wait for the corresponding thread to complete its execution. When
+the thread finishes, C<-E<gt>join()> will return the return value(s) of the
+entry point function.
+
+The context (void, scalar or list) for the return value(s) for C<-E<gt>join()>
+is determined at the time of thread creation.
+
+ # Create thread in list context (implicit)
+ my ($thr1) = threads->create(sub {
+ my @results = qw(a b c);
+ return (@results);
+ });
+ # or (explicit)
+ my $thr1 = threads->create({'context' => 'list'},
+ sub {
+ my @results = qw(a b c);
+ return (@results);
+ });
+ # Retrieve list results from thread
+ my @res1 = $thr1->join();
+
+ # Create thread in scalar context (implicit)
+ my $thr2 = threads->create(sub {
+ my $result = 42;
+ return ($result);
+ });
+ # Retrieve scalar result from thread
+ my $res2 = $thr2->join();
+
+ # Create a thread in void context (explicit)
+ my $thr3 = threads->create({'void' => 1},
+ sub { print("Hello, world\n"); });
+ # Join the thread in void context (i.e., no return value)
+ $thr3->join();
+
+See L</"THREAD CONTEXT"> for more details.
+
+If the program exits without all threads having either been joined or
+detached, then a warning will be issued.
+
+Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already joined thread will
+cause an error to be thrown.
+
+=item $thr->detach()
+
+Makes the thread unjoinable, and causes any eventual return value to be
+discarded. When the program exits, any detached threads that are still
+running are silently terminated.
+
+If the program exits without all threads having either been joined or
+detached, then a warning will be issued.
+
+Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already detached thread
+will cause an error to be thrown.
+
+=item threads->detach()
+
+Class method that allows a thread to detach itself.
+
+=item threads->self()
+
+Class method that allows a thread to obtain its own I<threads> object.
+
+=item $thr->tid()
+
+Returns the ID of the thread. Thread IDs are unique integers with the main
+thread in a program being 0, and incrementing by 1 for every thread created.
+
+=item threads->tid()
+
+Class method that allows a thread to obtain its own ID.
+
+=item "$thr"
+
+If you add the C<stringify> import option to your C<use threads> declaration,
+then using a threads object in a string or a string context (e.g., as a hash
+key) will cause its ID to be used as the value:
+
+ use threads qw(stringify);
+
+ my $thr = threads->create(...);
+ print("Thread $thr started...\n"); # Prints out: Thread 1 started...
+
+=item threads->object($tid)
+
+This will return the I<threads> object for the I<active> thread associated
+with the specified thread ID. Returns C<undef> if there is no thread
+associated with the TID, if the thread is joined or detached, if no TID is
+specified or if the specified TID is undef.
+
+=item threads->yield()
+
+This is a suggestion to the OS to let this thread yield CPU time to other
+threads. What actually happens is highly dependent upon the underlying
+thread implementation.
+
+You may do C<use threads qw(yield)>, and then just use C<yield()> in your
+code.
+
+=item threads->list()
+
+=item threads->list(threads::all)
+
+=item threads->list(threads::running)
+
+=item threads->list(threads::joinable)
+
+With no arguments (or using C<threads::all>) and in a list context, returns a
+list of all non-joined, non-detached I<threads> objects. In a scalar context,
+returns a count of the same.
+
+With a I<true> argument (using C<threads::running>), returns a list of all
+non-joined, non-detached I<threads> objects that are still running.
+
+With a I<false> argument (using C<threads::joinable>), returns a list of all
+non-joined, non-detached I<threads> objects that have finished running (i.e.,
+for which C<-E<gt>join()> will not I<block>).
+
+=item $thr1->equal($thr2)
+
+Tests if two threads objects are the same thread or not. This is overloaded
+to the more natural forms:
+
+ if ($thr1 == $thr2) {
+ print("Threads are the same\n");
+ }
+ # or
+ if ($thr1 != $thr2) {
+ print("Threads differ\n");
+ }
+
+(Thread comparison is based on thread IDs.)
+
+=item async BLOCK;
+
+C<async> creates a thread to execute the block immediately following
+it. This block is treated as an anonymous subroutine, and so must have a
+semicolon after the closing brace. Like C<threads-E<gt>create()>, C<async>
+returns a I<threads> object.
+
+=item $thr->error()
+
+Threads are executed in an C<eval> context. This method will return C<undef>
+if the thread terminates I<normally>. Otherwise, it returns the value of
+C<$@> associated with the thread's execution status in its C<eval> context.
+
+=item $thr->_handle()
+
+This I<private> method returns the memory location of the internal thread
+structure associated with a threads object. For Win32, this is a pointer to
+the C<HANDLE> value returned by C<CreateThread> (i.e., C<HANDLE *>); for other
+platforms, it is a pointer to the C<pthread_t> structure used in the
+C<pthread_create> call (i.e., C<pthread_t *>).
+
+This method is of no use for general Perl threads programming. Its intent is
+to provide other (XS-based) thread modules with the capability to access, and
+possibly manipulate, the underlying thread structure associated with a Perl
+thread.
+
+=item threads->_handle()
+
+Class method that allows a thread to obtain its own I<handle>.
+
+=back
+
+=head1 EXITING A THREAD
+
+The usual method for terminating a thread is to
+L<return()|perlfunc/"return EXPR"> from the entry point function with the
+appropriate return value(s).
+
+=over
+
+=item threads->exit()
+
+If needed, a thread can be exited at any time by calling
+C<threads-E<gt>exit()>. This will cause the thread to return C<undef> in a
+scalar context, or the empty list in a list context.
+
+When called from the I<main> thread, this behaves the same as C<exit(0)>.
+
+=item threads->exit(status)
+
+When called from a thread, this behaves like C<threads-E<gt>exit()> (i.e., the
+exit status code is ignored).
+
+When called from the I<main> thread, this behaves the same as C<exit(status)>.
+
+=item die()
+
+Calling C<die()> in a thread indicates an abnormal exit for the thread. Any
+C<$SIG{__DIE__}> handler in the thread will be called first, and then the
+thread will exit with a warning message that will contain any arguments passed
+in the C<die()> call.
+
+=item exit(status)
+
+Calling L<exit()|perlfunc/"exit EXPR"> inside a thread causes the whole
+application to terminate. Because of this, the use of C<exit()> inside
+threaded code, or in modules that might be used in threaded applications, is
+strongly discouraged.
+
+If C<exit()> really is needed, then consider using the following:
+
+ threads->exit() if threads->can('exit'); # Thread friendly
+ exit(status);
+
+=item use threads 'exit' => 'threads_only'
+
+This globally overrides the default behavior of calling C<exit()> inside a
+thread, and effectively causes such calls to behave the same as
+C<threads-E<gt>exit()>. In other words, with this setting, calling C<exit()>
+causes only the thread to terminate.
+
+Because of its global effect, this setting should not be used inside modules
+or the like.
+
+The I<main> thread is unaffected by this setting.
+
+=item threads->create({'exit' => 'thread_only'}, ...)
+
+This overrides the default behavior of C<exit()> inside the newly created
+thread only.
+
+=item $thr->set_thread_exit_only(boolean)
+
+This can be used to change the I<exit thread only> behavior for a thread after
+it has been created. With a I<true> argument, C<exit()> will cause only the
+thread to exit. With a I<false> argument, C<exit()> will terminate the
+application.
+
+The I<main> thread is unaffected by this call.
+
+=item threads->set_thread_exit_only(boolean)
+
+Class method for use inside a thread to change its own behavior for C<exit()>.
+
+The I<main> thread is unaffected by this call.
+
+=back
+
+=head1 THREAD STATE
+
+The following boolean methods are useful in determining the I<state> of a
+thread.
+
+=over
+
+=item $thr->is_running()
+
+Returns true if a thread is still running (i.e., if its entry point function
+has not yet finished or exited).
+
+=item $thr->is_joinable()
+
+Returns true if the thread has finished running, is not detached and has not
+yet been joined. In other words, the thread is ready to be joined, and a call
+to C<$thr-E<gt>join()> will not I<block>.
+
+=item $thr->is_detached()
+
+Returns true if the thread has been detached.
+
+=item threads->is_detached()
+
+Class method that allows a thread to determine whether or not it is detached.
+
+=back
+
+=head1 THREAD CONTEXT
+
+As with subroutines, the type of value returned from a thread's entry point
+function may be determined by the thread's I<context>: list, scalar or void.
+The thread's context is determined at thread creation. This is necessary so
+that the context is available to the entry point function via
+L<wantarray()|perlfunc/"wantarray">. The thread may then specify a value of
+the appropriate type to be returned from C<-E<gt>join()>.
+
+=head2 Explicit context
+
+Because thread creation and thread joining may occur in different contexts, it
+may be desirable to state the context explicitly to the thread's entry point
+function. This may be done by calling C<-E<gt>create()> with a hash reference
+as the first argument:
+
+ my $thr = threads->create({'context' => 'list'}, \&foo);
+ ...
+ my @results = $thr->join();
+
+In the above, the threads object is returned to the parent thread in scalar
+context, and the thread's entry point function C<foo> will be called in list
+(array) context such that the parent thread can receive a list (array) from
+the C<-E<gt>join()> call. (C<'array'> is synonymous with C<'list'>.)
+
+Similarly, if you need the threads object, but your thread will not be
+returning a value (i.e., I<void> context), you would do the following:
+
+ my $thr = threads->create({'context' => 'void'}, \&foo);
+ ...
+ $thr->join();
+
+The context type may also be used as the I<key> in the hash reference followed
+by a I<true> value:
+
+ threads->create({'scalar' => 1}, \&foo);
+ ...
+ my ($thr) = threads->list();
+ my $result = $thr->join();
+
+=head2 Implicit context
+
+If not explicitly stated, the thread's context is implied from the context
+of the C<-E<gt>create()> call:
+
+ # Create thread in list context
+ my ($thr) = threads->create(...);
+
+ # Create thread in scalar context
+ my $thr = threads->create(...);
+
+ # Create thread in void context
+ threads->create(...);
+
+=head2 $thr->wantarray()
+
+This returns the thread's context in the same manner as
+L<wantarray()|perlfunc/"wantarray">.
+
+=head2 threads->wantarray()
+
+Class method to return the current thread's context. This returns the same
+value as running L<wantarray()|perlfunc/"wantarray"> inside the current
+thread's entry point function.
+
+=head1 THREAD STACK SIZE
+
+The default per-thread stack size for different platforms varies
+significantly, and is almost always far more than is needed for most
+applications. On Win32, Perl's makefile explicitly sets the default stack to
+16 MB; on most other platforms, the system default is used, which again may be
+much larger than is needed.
+
+By tuning the stack size to more accurately reflect your application's needs,
+you may significantly reduce your application's memory usage, and increase the
+number of simultaneously running threads.
+
+Note that on Windows, address space allocation granularity is 64 KB,
+therefore, setting the stack smaller than that on Win32 Perl will not save any
+more memory.
+
+=over
+
+=item threads->get_stack_size();
+
+Returns the current default per-thread stack size. The default is zero, which
+means the system default stack size is currently in use.
+
+=item $size = $thr->get_stack_size();
+
+Returns the stack size for a particular thread. A return value of zero
+indicates the system default stack size was used for the thread.
+
+=item $old_size = threads->set_stack_size($new_size);
+
+Sets a new default per-thread stack size, and returns the previous setting.
+
+Some platforms have a minimum thread stack size. Trying to set the stack size
+below this value will result in a warning, and the minimum stack size will be
+used.
+
+Some Linux platforms have a maximum stack size. Setting too large of a stack
+size will cause thread creation to fail.
+
+If needed, C<$new_size> will be rounded up to the next multiple of the memory
+page size (usually 4096 or 8192).
+
+Threads created after the stack size is set will then either call
+C<pthread_attr_setstacksize()> I<(for pthreads platforms)>, or supply the
+stack size to C<CreateThread()> I<(for Win32 Perl)>.
+
+(Obviously, this call does not affect any currently extant threads.)
+
+=item use threads ('stack_size' => VALUE);
+
+This sets the default per-thread stack size at the start of the application.
+
+=item $ENV{'PERL5_ITHREADS_STACK_SIZE'}
+
+The default per-thread stack size may be set at the start of the application
+through the use of the environment variable C<PERL5_ITHREADS_STACK_SIZE>:
+
+ PERL5_ITHREADS_STACK_SIZE=1048576
+ export PERL5_ITHREADS_STACK_SIZE
+ perl -e'use threads; print(threads->get_stack_size(), "\n")'
+
+This value overrides any C<stack_size> parameter given to C<use threads>. Its
+primary purpose is to permit setting the per-thread stack size for legacy
+threaded applications.
+
+=item threads->create({'stack_size' => VALUE}, FUNCTION, ARGS)
+
+To specify a particular stack size for any individual thread, call
+C<-E<gt>create()> with a hash reference as the first argument:
+
+ my $thr = threads->create({'stack_size' => 32*4096}, \&foo, @args);
+
+=item $thr2 = $thr1->create(FUNCTION, ARGS)
+
+This creates a new thread (C<$thr2>) that inherits the stack size from an
+existing thread (C<$thr1>). This is shorthand for the following:
+
+ my $stack_size = $thr1->get_stack_size();
+ my $thr2 = threads->create({'stack_size' => $stack_size}, FUNCTION, ARGS);
+
+=back
+
+=head1 THREAD SIGNALLING
+
+When safe signals is in effect (the default behavior - see L</"Unsafe signals">
+for more details), then signals may be sent and acted upon by individual
+threads.
+
+=over 4
+
+=item $thr->kill('SIG...');
+
+Sends the specified signal to the thread. Signal names and (positive) signal
+numbers are the same as those supported by
+L<kill()|perlfunc/"kill SIGNAL, LIST">. For example, 'SIGTERM', 'TERM' and
+(depending on the OS) 15 are all valid arguments to C<-E<gt>kill()>.
+
+Returns the thread object to allow for method chaining:
+
+ $thr->kill('SIG...')->join();
+
+=back
+
+Signal handlers need to be set up in the threads for the signals they are
+expected to act upon. Here's an example for I<cancelling> a thread:
+
+ use threads;
+
+ sub thr_func
+ {
+ # Thread 'cancellation' signal handler
+ $SIG{'KILL'} = sub { threads->exit(); };
+
+ ...
+ }
+
+ # Create a thread
+ my $thr = threads->create('thr_func');
+
+ ...
+
+ # Signal the thread to terminate, and then detach
+ # it so that it will get cleaned up automatically
+ $thr->kill('KILL')->detach();
+
+Here's another simplistic example that illustrates the use of thread
+signalling in conjunction with a semaphore to provide rudimentary I<suspend>
+and I<resume> capabilities:
+
+ use threads;
+ use Thread::Semaphore;
+
+ sub thr_func
+ {
+ my $sema = shift;
+
+ # Thread 'suspend/resume' signal handler
+ $SIG{'STOP'} = sub {
+ $sema->down(); # Thread suspended
+ $sema->up(); # Thread resumes
+ };
+
+ ...
+ }
+
+ # Create a semaphore and pass it to a thread
+ my $sema = Thread::Semaphore->new();
+ my $thr = threads->create('thr_func', $sema);
+
+ # Suspend the thread
+ $sema->down();
+ $thr->kill('STOP');
+
+ ...
+
+ # Allow the thread to continue
+ $sema->up();
+
+CAVEAT: The thread signalling capability provided by this module does not
+actually send signals via the OS. It I<emulates> signals at the Perl-level
+such that signal handlers are called in the appropriate thread. For example,
+sending C<$thr-E<gt>kill('STOP')> does not actually suspend a thread (or the
+whole process), but does cause a C<$SIG{'STOP'}> handler to be called in that
+thread (as illustrated above).
+
+As such, signals that would normally not be appropriate to use in the
+C<kill()> command (e.g., C<kill('KILL', $$)>) are okay to use with the
+C<-E<gt>kill()> method (again, as illustrated above).
+
+Correspondingly, sending a signal to a thread does not disrupt the operation
+the thread is currently working on: The signal will be acted upon after the
+current operation has completed. For instance, if the thread is I<stuck> on
+an I/O call, sending it a signal will not cause the I/O call to be interrupted
+such that the signal is acted up immediately.
+
+Sending a signal to a terminated thread is ignored.
+
+=head1 WARNINGS
+
+=over 4
+
+=item Perl exited with active threads:
+
+If the program exits without all threads having either been joined or
+detached, then this warning will be issued.
+
+NOTE: If the I<main> thread exits, then this warning cannot be suppressed
+using C<no warnings 'threads';> as suggested below.
+
+=item Thread creation failed: pthread_create returned #
+
+See the appropriate I<man> page for C<pthread_create> to determine the actual
+cause for the failure.
+
+=item Thread # terminated abnormally: ...
+
+A thread terminated in some manner other than just returning from its entry
+point function, or by using C<threads-E<gt>exit()>. For example, the thread
+may have terminated because of an error, or by using C<die>.
+
+=item Using minimum thread stack size of #
+
+Some platforms have a minimum thread stack size. Trying to set the stack size
+below this value will result in the above warning, and the stack size will be
+set to the minimum.
+
+=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22
+
+The specified I<SIZE> exceeds the system's maximum stack size. Use a smaller
+value for the stack size.
+
+=back
+
+If needed, thread warnings can be suppressed by using:
+
+ no warnings 'threads';
+
+in the appropriate scope.
+
+=head1 ERRORS
+
+=over 4
+
+=item This Perl not built to support threads
+
+The particular copy of Perl that you're trying to use was not built using the
+C<useithreads> configuration option.
+
+Having threads support requires all of Perl and all of the XS modules in the
+Perl installation to be rebuilt; it is not just a question of adding the
+L<threads> module (i.e., threaded and non-threaded Perls are binary
+incompatible.)
+
+=item Cannot change stack size of an existing thread
+
+The stack size of currently extant threads cannot be changed, therefore, the
+following results in the above error:
+
+ $thr->set_stack_size($size);
+
+=item Cannot signal threads without safe signals
+
+Safe signals must be in effect to use the C<-E<gt>kill()> signalling method.
+See L</"Unsafe signals"> for more details.
+
+=item Unrecognized signal name: ...
+
+The particular copy of Perl that you're trying to use does not support the
+specified signal being used in a C<-E<gt>kill()> call.
+
+=back
+
+=head1 BUGS AND LIMITATIONS
+
+Before you consider posting a bug report, please consult, and possibly post a
+message to the discussion forum to see if what you've encountered is a known
+problem.
+
+=over
+
+=item Thread-safe modules
+
+See L<perlmod/"Making your module threadsafe"> when creating modules that may
+be used in threaded applications, especially if those modules use non-Perl
+data, or XS code.
+
+=item Using non-thread-safe modules
+
+Unfortunately, you may encounter Perl modules that are not I<thread-safe>.
+For example, they may crash the Perl interpreter during execution, or may dump
+core on termination. Depending on the module and the requirements of your
+application, it may be possible to work around such difficulties.
+
+If the module will only be used inside a thread, you can try loading the
+module from inside the thread entry point function using C<require> (and
+C<import> if needed):
+
+ sub thr_func
+ {
+ require Unsafe::Module
+ # Unsafe::Module->import(...);
+
+ ....
+ }
+
+If the module is needed inside the I<main> thread, try modifying your
+application so that the module is loaded (again using C<require> and
+C<-E<gt>import()>) after any threads are started, and in such a way that no
+other threads are started afterwards.
+
+If the above does not work, or is not adequate for your application, then file
+a bug report on L<http://rt.cpan.org/Public/> against the problematic module.
+
+=item Current working directory
+
+On all platforms except MSWin32, the setting for the current working directory
+is shared among all threads such that changing it in one thread (e.g., using
+C<chdir()>) will affect all the threads in the application.
+
+On MSWin32, each thread maintains its own the current working directory
+setting.
+
+=item Environment variables
+
+Currently, on all platforms except MSWin32, all I<system> calls (e.g., using
+C<system()> or back-ticks) made from threads use the environment variable
+settings from the I<main> thread. In other words, changes made to C<%ENV> in
+a thread will not be visible in I<system> calls made by that thread.
+
+To work around this, set environment variables as part of the I<system> call.
+For example:
+
+ my $msg = 'hello';
+ system("FOO=$msg; echo \$FOO"); # Outputs 'hello' to STDOUT
+
+On MSWin32, each thread maintains its own set of environment variables.
+
+=item Parent-child threads
+
+On some platforms, it might not be possible to destroy I<parent> threads while
+there are still existing I<child> threads.
+
+=item Creating threads inside special blocks
+
+Creating threads inside C<BEGIN>, C<CHECK> or C<INIT> blocks should not be
+relied upon. Depending on the Perl version and the application code, results
+may range from success, to (apparently harmless) warnings of leaked scalar, or
+all the way up to crashing of the Perl interpreter.
+
+=item Unsafe signals
+
+Since Perl 5.8.0, signals have been made safer in Perl by postponing their
+handling until the interpreter is in a I<safe> state. See
+L<perl58delta/"Safe Signals"> and L<perlipc/"Deferred Signals (Safe Signals)">
+for more details.
+
+Safe signals is the default behavior, and the old, immediate, unsafe
+signalling behavior is only in effect in the following situations:
+
+=over 4
+
+=item * Perl has been built with C<PERL_OLD_SIGNALS> (see C<perl -V>).
+
+=item * The environment variable C<PERL_SIGNALS> is set to C<unsafe> (see L<perlrun/"PERL_SIGNALS">).
+
+=item * The module L<Perl::Unsafe::Signals> is used.
+
+=back
+
+If unsafe signals is in effect, then signal handling is not thread-safe, and
+the C<-E<gt>kill()> signalling method cannot be used.
+
+=item Returning closures from threads
+
+Returning closures from threads should not be relied upon. Depending of the
+Perl version and the application code, results may range from success, to
+(apparently harmless) warnings of leaked scalar, or all the way up to crashing
+of the Perl interpreter.
+
+=item Returning objects from threads
+
+Returning objects from threads does not work. Depending on the classes
+involved, you may be able to work around this by returning a serialized
+version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then
+reconstituting it in the joining thread. If you're using Perl 5.10.0 or
+later, and if the class supports L<shared objects|threads::shared/"OBJECTS">,
+you can pass them via L<shared queues| Thread::Queue>.
+
+=item END blocks in threads
+
+It is possible to add L<END blocks|perlmod/"BEGIN, UNITCHECK, CHECK, INIT and
+END"> to threads by using L<require|perlfunc/"require VERSION"> or
+L<eval|perlfunc/"eval EXPR"> with the appropriate code. These C<END> blocks
+will then be executed when the thread's interpreter is destroyed (i.e., either
+during a C<-E<gt>join()> call, or at program termination).
+
+However, calling any L<threads> methods in such an C<END> block will most
+likely I<fail> (e.g., the application may hang, or generate an error) due to
+mutexes that are needed to control functionality within the L<threads> module.
+
+For this reason, the use of C<END> blocks in threads is B<strongly>
+discouraged.
+
+=item Perl Bugs and the CPAN Version of L<threads>
+
+Support for threads extends beyond the code in this module (i.e.,
+F<threads.pm> and F<threads.xs>), and into the Perl interpreter itself. Older
+versions of Perl contain bugs that may manifest themselves despite using the
+latest version of L<threads> from CPAN. There is no workaround for this other
+than upgrading to the latest version of Perl.
+
+Even with the latest version of Perl, it is known that certain constructs
+with threads may result in warning messages concerning leaked scalars or
+unreferenced scalars. However, such warnings are harmless, and may safely be
+ignored.
+
+You can search for L<threads> related bug reports at
+L<http://rt.cpan.org/Public/>. If needed submit any new bugs, problems,
+patches, etc. to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads>
+
+=back
+
+=head1 REQUIREMENTS
+
+Perl 5.8.0 or later
+
+=head1 SEE ALSO
+
+L<threads> Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/threads>
+
+Annotated POD for L<threads>:
+L<http://annocpan.org/~JDHEDDEN/threads-1.75/threads.pm>
+
+Source repository:
+L<http://code.google.com/p/threads-shared/>
+
+L<threads::shared>, 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>
+
+Stack size discussion:
+L<http://www.perlmonks.org/?node_id=532956>
+
+=head1 AUTHOR
+
+Artur Bergman E<lt>sky AT crucially DOT netE<gt>
+
+CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
+
+=head1 LICENSE
+
+threads is released under the same license as Perl.
+
+=head1 ACKNOWLEDGEMENTS
+
+Richard Soderberg E<lt>perl AT crystalflame DOT netE<gt> -
+Helping me out tons, trying to find reasons for races and other weird bugs!
+
+Simon Cozens E<lt>simon AT brecon DOT co DOT ukE<gt> -
+Being there to answer zillions of annoying questions
+
+Rocco Caputo E<lt>troc AT netrus DOT netE<gt>
+
+Vipul Ved Prakash E<lt>mail AT vipul DOT netE<gt> -
+Helping with debugging
+
+Dean Arnold E<lt>darnold AT presicient DOT comE<gt> -
+Stack size API
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/timelocal.pl b/Master/tlpkg/tlperl/lib/timelocal.pl
new file mode 100644
index 00000000000..5e08dad9e34
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/timelocal.pl
@@ -0,0 +1,21 @@
+;# timelocal.pl
+;#
+;# Usage:
+;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
+;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
+
+;# This file has been superseded by the Time::Local library module.
+;# It is implemented as a call to that module for backwards compatibility
+;# with code written for perl4; new code should use Time::Local directly.
+;# This legacy library is deprecated and will be removed in a future
+;# release of perl.
+
+;# The current implementation shares with the original the questionable
+;# behavior of defining the timelocal() and timegm() functions in the
+;# namespace of whatever package was current when the first instance of
+;# C<require 'timelocal.pl';> was executed in a program.
+
+use Time::Local;
+
+*timelocal::cheat = \&Time::Local::cheat;
+
diff --git a/Master/tlpkg/tlperl/lib/utf8.pm b/Master/tlpkg/tlperl/lib/utf8.pm
new file mode 100644
index 00000000000..ed0a4d8315f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/utf8.pm
@@ -0,0 +1,214 @@
+package utf8;
+
+$utf8::hint_bits = 0x00800000;
+
+our $VERSION = '1.08';
+
+sub import {
+ $^H |= $utf8::hint_bits;
+ $enc{caller()} = $_[1] if $_[1];
+}
+
+sub unimport {
+ $^H &= ~$utf8::hint_bits;
+}
+
+sub AUTOLOAD {
+ require "utf8_heavy.pl";
+ goto &$AUTOLOAD if defined &$AUTOLOAD;
+ require Carp;
+ Carp::croak("Undefined subroutine $AUTOLOAD called");
+}
+
+1;
+__END__
+
+=head1 NAME
+
+utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source code
+
+=head1 SYNOPSIS
+
+ use utf8;
+ no utf8;
+
+ # Convert the internal representation of a Perl scalar to/from UTF-8.
+
+ $num_octets = utf8::upgrade($string);
+ $success = utf8::downgrade($string[, FAIL_OK]);
+
+ # Change each character of a Perl scalar to/from a series of
+ # characters that represent the UTF-8 bytes of each original character.
+
+ utf8::encode($string); # "\x{100}" becomes "\xc4\x80"
+ utf8::decode($string); # "\xc4\x80" becomes "\x{100}"
+
+ $flag = utf8::is_utf8(STRING); # since Perl 5.8.1
+ $flag = utf8::valid(STRING);
+
+=head1 DESCRIPTION
+
+The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the
+program text in the current lexical scope (allow UTF-EBCDIC on EBCDIC based
+platforms). The C<no utf8> pragma tells Perl to switch back to treating
+the source text as literal bytes in the current lexical scope.
+
+B<Do not use this pragma for anything else than telling Perl that your
+script is written in UTF-8.> The utility functions described below are
+directly usable without C<use utf8;>.
+
+Because it is not possible to reliably tell UTF-8 from native 8 bit
+encodings, you need either a Byte Order Mark at the beginning of your
+source code, or C<use utf8;>, to instruct perl.
+
+When UTF-8 becomes the standard source format, this pragma will
+effectively become a no-op. For convenience in what follows the term
+I<UTF-X> is used to refer to UTF-8 on ASCII and ISO Latin based
+platforms and UTF-EBCDIC on EBCDIC based platforms.
+
+See also the effects of the C<-C> switch and its cousin, the
+C<$ENV{PERL_UNICODE}>, in L<perlrun>.
+
+Enabling the C<utf8> pragma has the following effect:
+
+=over 4
+
+=item *
+
+Bytes in the source text that have their high-bit set will be treated
+as being part of a literal UTF-X sequence. This includes most
+literals such as identifier names, string constants, and constant
+regular expression patterns.
+
+On EBCDIC platforms characters in the Latin 1 character set are
+treated as being part of a literal UTF-EBCDIC character.
+
+=back
+
+Note that if you have bytes with the eighth bit on in your script
+(for example embedded Latin-1 in your string literals), C<use utf8>
+will be unhappy since the bytes are most probably not well-formed
+UTF-X. If you want to have such bytes under C<use utf8>, you can disable
+this pragma until the end the block (or file, if at top level) by
+C<no utf8;>.
+
+=head2 Utility functions
+
+The following functions are defined in the C<utf8::> package by the
+Perl core. You do not need to say C<use utf8> to use these and in fact
+you should not say that unless you really want to have UTF-8 source code.
+
+=over 4
+
+=item * $num_octets = utf8::upgrade($string)
+
+Converts in-place the internal representation of the string from an octet
+sequence in the native encoding (Latin-1 or EBCDIC) to I<UTF-X>. The
+logical character sequence itself is unchanged. If I<$string> is already
+stored as I<UTF-X>, then this is a no-op. Returns the
+number of octets necessary to represent the string as I<UTF-X>. Can be
+used to make sure that the UTF-8 flag is on, so that C<\w> or C<lc()>
+work as Unicode on strings containing characters in the range 0x80-0xFF
+(on ASCII and derivatives).
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore Encode is recommended for the general purposes; see also
+L<Encode>.
+
+=item * $success = utf8::downgrade($string[, FAIL_OK])
+
+Converts in-place the the internal representation of the string from
+I<UTF-X> to the equivalent octet sequence in the native encoding (Latin-1
+or EBCDIC). The logical character sequence itself is unchanged. If
+I<$string> is already stored as native 8 bit, then this is a no-op. Can
+be used to
+make sure that the UTF-8 flag is off, e.g. when you want to make sure
+that the substr() or length() function works with the usually faster
+byte algorithm.
+
+Fails if the original I<UTF-X> sequence cannot be represented in the
+native 8 bit encoding. On failure dies or, if the value of C<FAIL_OK> is
+true, returns false.
+
+Returns true on success.
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore Encode is recommended for the general purposes; see also
+L<Encode>.
+
+=item * utf8::encode($string)
+
+Converts in-place the character sequence to the corresponding octet
+sequence in I<UTF-X>. That is, every (possibly wide) character gets
+replaced with a sequence of one or more characters that represent the
+individual I<UTF-X> bytes of the character. The UTF8 flag is turned off.
+Returns nothing.
+
+ my $a = "\x{100}"; # $a contains one character, with ord 0x100
+ utf8::encode($a); # $a contains two characters, with ords 0xc4 and 0x80
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore Encode is recommended for the general purposes; see also
+L<Encode>.
+
+=item * $success = utf8::decode($string)
+
+Attempts to convert in-place the octet sequence in I<UTF-X> to the
+corresponding character sequence. That is, it replaces each sequence of
+characters in the string whose ords represent a valid UTF-X byte
+sequence, with the corresponding single character. The UTF-8 flag is
+turned on only if the source string contains multiple-byte I<UTF-X>
+characters. If I<$string> is invalid as I<UTF-X>, returns false;
+otherwise returns true.
+
+ my $a = "\xc4\x80"; # $a contains two characters, with ords 0xc4 and 0x80
+ utf8::decode($a); # $a contains one character, with ord 0x100
+
+B<Note that this function does not handle arbitrary encodings.>
+Therefore Encode is recommended for the general purposes; see also
+L<Encode>.
+
+=item * $flag = utf8::is_utf8(STRING)
+
+(Since Perl 5.8.1) Test whether STRING is in UTF-8 internally.
+Functionally the same as Encode::is_utf8().
+
+=item * $flag = utf8::valid(STRING)
+
+[INTERNAL] Test whether STRING is in a consistent state regarding
+UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag
+on B<or> if string is held as bytes (both these states are 'consistent').
+Main reason for this routine is to allow Perl's testsuite to check
+that operations have left strings in a consistent state. You most
+probably want to use utf8::is_utf8() instead.
+
+=back
+
+C<utf8::encode> is like C<utf8::upgrade>, but the UTF8 flag is
+cleared. See L<perlunicode> for more on the UTF8 flag and the C API
+functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>,
+and C<sv_utf8_decode>, which are wrapped by the Perl functions
+C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and
+C<utf8::decode>. Also, the functions utf8::is_utf8, utf8::valid,
+utf8::encode, utf8::decode, utf8::upgrade, and utf8::downgrade are
+actually internal, and thus always available, without a C<require utf8>
+statement.
+
+=head1 BUGS
+
+One can have Unicode in identifier names, but not in package/class or
+subroutine names. While some limited functionality towards this does
+exist as of Perl 5.8.0, that is more accidental than designed; use of
+Unicode for the said purposes is unsupported.
+
+One reason of this unfinishedness is its (currently) inherent
+unportability: since both package names and subroutine names may need
+to be mapped to file and directory names, the Unicode capability of
+the filesystem becomes important-- and there unfortunately aren't
+portable answers.
+
+=head1 SEE ALSO
+
+L<perlunitut>, L<perluniintro>, L<perlrun>, L<bytes>, L<perlunicode>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/utf8_heavy.pl b/Master/tlpkg/tlperl/lib/utf8_heavy.pl
new file mode 100644
index 00000000000..d473dd2a424
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/utf8_heavy.pl
@@ -0,0 +1,466 @@
+package utf8;
+use strict;
+use warnings;
+
+sub DEBUG () { 0 }
+
+sub DESTROY {}
+
+my %Cache;
+
+sub croak { require Carp; Carp::croak(@_) }
+
+##
+## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape.
+## It's a data structure that encodes a set of Unicode characters.
+##
+
+{
+ # If a floating point number is within this distance from the value of a
+ # fraction, it is considered to be that fraction, even if many more digits
+ # are specified that don't exactly match.
+ my $min_floating_slop;
+
+ sub SWASHNEW {
+ my ($class, $type, $list, $minbits, $none) = @_;
+ local $^D = 0 if $^D;
+
+ print STDERR __LINE__, ": ", join(", ", @_), "\n" if DEBUG;
+
+ ##
+ ## Get the list of codepoints for the type.
+ ## Called from swash_init (see utf8.c) or SWASHNEW itself.
+ ##
+ ## Callers of swash_init:
+ ## op.c:pmtrans -- for tr/// and y///
+ ## regexec.c:regclass_swash -- for /[]/, \p, and \P
+ ## utf8.c:is_utf8_common -- for common Unicode properties
+ ## utf8.c:to_utf8_case -- for lc, uc, ucfirst, etc. and //i
+ ##
+ ## Given a $type, our goal is to fill $list with the set of codepoint
+ ## ranges. If $type is false, $list passed is used.
+ ##
+ ## $minbits:
+ ## For binary properties, $minbits must be 1.
+ ## For character mappings (case and transliteration), $minbits must
+ ## be a number except 1.
+ ##
+ ## $list (or that filled according to $type):
+ ## Refer to perlunicode.pod, "User-Defined Character Properties."
+ ##
+ ## For binary properties, only characters with the property value
+ ## of True should be listed. The 3rd column, if any, will be ignored
+ ##
+ ## $none is undocumented, so I'm (khw) trying to do some documentation
+ ## of it now. It appears to be if there is a mapping in an input file
+ ## that maps to 'XXXX', then that is replaced by $none+1, expressed in
+ ## hexadecimal. The only place I found it possibly used was in
+ ## S_pmtrans in op.c.
+ ##
+ ## To make the parsing of $type clear, this code takes the a rather
+ ## unorthodox approach of last'ing out of the block once we have the
+ ## info we need. Were this to be a subroutine, the 'last' would just
+ ## be a 'return'.
+ ##
+ my $file; ## file to load data from, and also part of the %Cache key.
+ my $ListSorted = 0;
+
+ # Change this to get a different set of Unicode tables
+ my $unicore_dir = 'unicore';
+
+ if ($type)
+ {
+ $type =~ s/^\s+//;
+ $type =~ s/\s+$//;
+
+ print STDERR __LINE__, ": type = $type\n" if DEBUG;
+
+ GETFILE:
+ {
+ ##
+ ## It could be a user-defined property.
+ ##
+
+ my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+
+ if (defined $caller1 && $type =~ /^I[ns]\w+$/) {
+ my $prop = "${caller1}::$type";
+ if (exists &{$prop}) {
+ no strict 'refs';
+
+ $list = &{$prop};
+ last GETFILE;
+ }
+ }
+
+ require "$unicore_dir/Heavy.pl";
+
+ # Everything is caseless matching
+ my $property_and_table = lc $type;
+ print STDERR __LINE__, ": $property_and_table\n" if DEBUG;
+
+ # See if is of the compound form 'property=value', where the
+ # value indicates the table we should use.
+ my ($property, $table, @remainder) =
+ split /\s*[:=]\s*/, $property_and_table, -1;
+ return $type if @remainder;
+
+ my $prefix;
+ if (! defined $table) {
+
+ # Here, is the single form. The property becomes empty, and
+ # the whole value is the table.
+ $table = $property;
+ $prefix = $property = "";
+ } else {
+ print STDERR __LINE__, ": $property\n" if DEBUG;
+
+ # Here it is the compound property=table form. The property
+ # name is always loosely matched, which means remove any of
+ # these:
+ $property =~ s/[_\s-]//g;
+
+ # And convert to canonical form. Quit if not valid.
+ $property = $utf8::loose_property_name_of{$property};
+ return $type unless defined $property;
+
+ $prefix = "$property=";
+
+ # If the rhs looks like it is a number...
+ print STDERR __LINE__, ": table=$table\n" if DEBUG;
+ if ($table =~ qr{ ^ [ \s 0-9 _ + / . -]+ $ }x) {
+ print STDERR __LINE__, ": table=$table\n" if DEBUG;
+
+ # Don't allow leading nor trailing slashes
+ return $type if $table =~ / ^ \/ | \/ $ /x;
+
+ # Split on slash, in case it is a rational, like \p{1/5}
+ my @parts = split qr{ \s* / \s* }x, $table, -1;
+ print __LINE__, ": $type\n" if @parts > 2 && DEBUG;
+
+ # Can have maximum of one slash
+ return $type if @parts > 2;
+
+ foreach my $part (@parts) {
+ print __LINE__, ": part=$part\n" if DEBUG;
+
+ $part =~ s/^\+\s*//; # Remove leading plus
+ $part =~ s/^-\s*/-/; # Remove blanks after unary
+ # minus
+
+ # Remove underscores between digits.
+ $part =~ s/( ?<= [0-9] ) _ (?= [0-9] ) //xg;
+
+ # No leading zeros (but don't make a single '0'
+ # into a null string)
+ $part =~ s/ ^ ( -? ) 0+ /$1/x;
+ $part .= '0' if $part eq '-' || $part eq "";
+
+ # No trailing zeros after a decimal point
+ $part =~ s/ ( \. .*? ) 0+ $ /$1/x;
+
+ # Begin with a 0 if a leading decimal point
+ $part =~ s/ ^ ( -? ) \. /${1}0./x;
+
+ # Ensure not a trailing decimal point: turn into an
+ # integer
+ $part =~ s/ \. $ //x;
+
+ print STDERR __LINE__, ": part=$part\n" if DEBUG;
+ #return $type if $part eq "";
+
+ # Result better look like a number. (This test is
+ # needed because, for example could have a plus in
+ # the middle.)
+ return $type if $part
+ !~ / ^ -? [0-9]+ ( \. [0-9]+)? $ /x;
+ }
+
+ # If a rational...
+ if (@parts == 2) {
+
+ # If denominator is negative, get rid of it, and ...
+ if ($parts[1] =~ s/^-//) {
+
+ # If numerator is also negative, convert the
+ # whole thing to positive, or move the minus to
+ # the numerator
+ if ($parts[0] !~ s/^-//) {
+ $parts[0] = '-' . $parts[0];
+ }
+ }
+ $table = join '/', @parts;
+ }
+ elsif ($property ne 'nv' || $parts[0] !~ /\./) {
+
+ # Here is not numeric value, or doesn't have a
+ # decimal point. No further manipulation is
+ # necessary. (Note the hard-coded property name.
+ # This could fail if other properties eventually
+ # had fractions as well; perhaps the cjk ones
+ # could evolve to do that. This hard-coding could
+ # be fixed by mktables generating a list of
+ # properties that could have fractions.)
+ $table = $parts[0];
+ } else {
+
+ # Here is a floating point numeric_value. Try to
+ # convert to rational. First see if is in the list
+ # of known ones.
+ if (exists $utf8::nv_floating_to_rational{$parts[0]}) {
+ $table = $utf8::nv_floating_to_rational{$parts[0]};
+ } else {
+
+ # Here not in the list. See if is close
+ # enough to something in the list. First
+ # determine what 'close enough' means. It has
+ # to be as tight as what mktables says is the
+ # maximum slop, and as tight as how many
+ # digits we were passed. That is, if the user
+ # said .667, .6667, .66667, etc. we match as
+ # many digits as they passed until get to
+ # where it doesn't matter any more due to the
+ # machine's precision. If they said .6666668,
+ # we fail.
+ (my $fraction = $parts[0]) =~ s/^.*\.//;
+ my $epsilon = 10 ** - (length($fraction));
+ if ($epsilon > $utf8::max_floating_slop) {
+ $epsilon = $utf8::max_floating_slop;
+ }
+
+ # But it can't be tighter than the minimum
+ # precision for this machine. If haven't
+ # already calculated that minimum, do so now.
+ if (! defined $min_floating_slop) {
+
+ # Keep going down an order of magnitude
+ # until find that adding this quantity to
+ # 1 remains 1; but put an upper limit on
+ # this so in case this algorithm doesn't
+ # work properly on some platform, that we
+ # won't loop forever.
+ my $count = 0;
+ $min_floating_slop = 1;
+ while (1+ $min_floating_slop != 1
+ && $count++ < 50)
+ {
+ my $next = $min_floating_slop / 10;
+ last if $next == 0; # If underflows,
+ # use previous one
+ $min_floating_slop = $next;
+ print STDERR __LINE__, ": min_float_slop=$min_floating_slop\n" if DEBUG;
+ }
+
+ # Back off a couple orders of magnitude,
+ # just to be safe.
+ $min_floating_slop *= 100;
+ }
+
+ if ($epsilon < $min_floating_slop) {
+ $epsilon = $min_floating_slop;
+ }
+ print STDERR __LINE__, ": fraction=.$fraction; epsilon=$epsilon\n" if DEBUG;
+
+ undef $table;
+
+ # And for each possible rational in the table,
+ # see if it is within epsilon of the input.
+ foreach my $official
+ (keys %utf8::nv_floating_to_rational)
+ {
+ print STDERR __LINE__, ": epsilon=$epsilon, official=$official, diff=", abs($parts[0] - $official), "\n" if DEBUG;
+ if (abs($parts[0] - $official) < $epsilon) {
+ $table =
+ $utf8::nv_floating_to_rational{$official};
+ last;
+ }
+ }
+
+ # Quit if didn't find one.
+ return $type unless defined $table;
+ }
+ }
+ print STDERR __LINE__, ": $property=$table\n" if DEBUG;
+ }
+ }
+
+ # Combine lhs (if any) and rhs to get something that matches
+ # the syntax of the lookups.
+ $property_and_table = "$prefix$table";
+ print STDERR __LINE__, ": $property_and_table\n" if DEBUG;
+
+ # First try stricter matching.
+ $file = $utf8::stricter_to_file_of{$property_and_table};
+
+ # If didn't find it, try again with looser matching by editing
+ # out the applicable characters on the rhs and looking up
+ # again.
+ if (! defined $file) {
+ $table =~ s/ [_\s-] //xg;
+ $property_and_table = "$prefix$table";
+ print STDERR __LINE__, ": $property_and_table\n" if DEBUG;
+ $file = $utf8::loose_to_file_of{$property_and_table};
+ }
+
+ # Add the constant and go fetch it in.
+ if (defined $file) {
+ if ($utf8::why_deprecated{$file}) {
+ warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};");
+ }
+ $file= "$unicore_dir/lib/$file.pl";
+ last GETFILE;
+ }
+ print STDERR __LINE__, ": didn't find $property_and_table\n" if DEBUG;
+
+ ##
+ ## See if it's a user-level "To".
+ ##
+
+ my $caller0 = caller(0);
+
+ if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
+ my $map = $caller0 . "::" . $type;
+
+ if (exists &{$map}) {
+ no strict 'refs';
+
+ $list = &{$map};
+ last GETFILE;
+ }
+ }
+
+ ##
+ ## Last attempt -- see if it's a standard "To" name
+ ## (e.g. "ToLower") ToTitle is used by ucfirst().
+ ## The user-level way to access ToDigit() and ToFold()
+ ## is to use Unicode::UCD.
+ ##
+ if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/) {
+ $file = "$unicore_dir/To/$1.pl";
+ ## would like to test to see if $file actually exists....
+ last GETFILE;
+ }
+
+ ##
+ ## If we reach this line, it's because we couldn't figure
+ ## out what to do with $type. Ouch.
+ ##
+
+ return $type;
+ }
+
+ if (defined $file) {
+ print STDERR __LINE__, ": found it (file='$file')\n" if DEBUG;
+
+ ##
+ ## If we reach here, it was due to a 'last GETFILE' above
+ ## (exception: user-defined properties and mappings), so we
+ ## have a filename, so now we load it if we haven't already.
+ ## If we have, return the cached results. The cache key is the
+ ## class and file to load.
+ ##
+ my $found = $Cache{$class, $file};
+ if ($found and ref($found) eq $class) {
+ print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}\n" if DEBUG;
+ return $found;
+ }
+
+ local $@;
+ local $!;
+ $list = do $file; die $@ if $@;
+ }
+
+ $ListSorted = 1; ## we know that these lists are sorted
+ }
+
+ my $extras;
+ my $bits = $minbits;
+
+ my $ORIG = $list;
+ if ($list) {
+ my @tmp = split(/^/m, $list);
+ my %seen;
+ no warnings;
+ $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
+ $list = join '',
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map { /^([0-9a-fA-F]+)/; [ CORE::hex($1), $_ ] }
+ grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
+ }
+
+ if ($none) {
+ my $hextra = sprintf "%04x", $none + 1;
+ $list =~ s/\tXXXX$/\t$hextra/mg;
+ }
+
+ if ($minbits != 1 && $minbits < 32) { # not binary property
+ my $top = 0;
+ while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
+ my $min = CORE::hex $1;
+ my $max = defined $2 ? CORE::hex $2 : $min;
+ my $val = defined $3 ? CORE::hex $3 : 0;
+ $val += $max - $min if defined $3;
+ $top = $val if $val > $top;
+ }
+ my $topbits =
+ $top > 0xffff ? 32 :
+ $top > 0xff ? 16 : 8;
+ $bits = $topbits if $bits < $topbits;
+ }
+
+ my @extras;
+ if ($extras) {
+ for my $x ($extras) {
+ pos $x = 0;
+ while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
+ my $char = $1;
+ my $name = $2;
+ print STDERR __LINE__, ": $1 => $2\n" if DEBUG;
+ if ($char =~ /[-+!&]/) {
+ my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really
+ my $subobj;
+ if ($c eq 'utf8') {
+ $subobj = utf8->SWASHNEW($t, "", $minbits, 0);
+ }
+ elsif (exists &$name) {
+ $subobj = utf8->SWASHNEW($name, "", $minbits, 0);
+ }
+ elsif ($c =~ /^([0-9a-fA-F]+)/) {
+ $subobj = utf8->SWASHNEW("", $c, $minbits, 0);
+ }
+ return $subobj unless ref $subobj;
+ push @extras, $name => $subobj;
+ $bits = $subobj->{BITS} if $bits < $subobj->{BITS};
+ }
+ }
+ }
+ }
+
+ if (DEBUG) {
+ print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none";
+ print STDERR "\nLIST =>\n$list" if defined $list;
+ print STDERR "\nEXTRAS =>\n$extras" if defined $extras;
+ print STDERR "\n";
+ }
+
+ my $SWASH = bless {
+ TYPE => $type,
+ BITS => $bits,
+ EXTRAS => $extras,
+ LIST => $list,
+ NONE => $none,
+ @extras,
+ } => $class;
+
+ if ($file) {
+ $Cache{$class, $file} = $SWASH;
+ }
+
+ return $SWASH;
+ }
+}
+
+# Now SWASHGET is recasted into a C function S_swash_get (see utf8.c).
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/validate.pl b/Master/tlpkg/tlperl/lib/validate.pl
new file mode 100644
index 00000000000..c6558723330
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/validate.pl
@@ -0,0 +1,102 @@
+;# The validate routine takes a single multiline string consisting of
+;# lines 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 '|| die' to make it a fatal error if the file test fails.
+;# The default is '|| 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 -r, -w and -x.
+;# Only the first failed test of the bunch will produce a warning.
+
+;# The routine returns the number of warnings issued.
+
+;# Usage:
+;# require "validate.pl";
+;# $warnings += do validate('
+;# /vmunix -e || die
+;# /boot -e || die
+;# /bin cd
+;# csh -ex
+;# csh !-ug
+;# sh -ex
+;# sh !-ug
+;# /usr -d || warn "What happened to $file?\n"
+;# ');
+
+sub validate {
+ local($file,$test,$warnings,$oldwarnings);
+ foreach $check (split(/\n/,$_[0])) {
+ next if $check =~ /^#/;
+ next if $check =~ /^$/;
+ ($file,$test) = split(' ',$check,2);
+ if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
+ $testlist = $2;
+ @testlist = split(//,$testlist);
+ }
+ else {
+ @testlist = ('Z');
+ }
+ $oldwarnings = $warnings;
+ foreach $one (@testlist) {
+ $this = $test;
+ $this =~ s/(-\w\b)/$1 \$file/g;
+ $this =~ s/-Z/-$one/;
+ $this .= ' || warn' unless $this =~ /\|\|/;
+ $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
+ $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
+ eval $this;
+ last if $warnings > $oldwarnings;
+ }
+ }
+ $warnings;
+}
+
+sub valmess {
+ local($disposition,$this) = @_;
+ $file = $cwd . '/' . $file unless $file =~ m|^/|;
+ if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
+ $neg = $1;
+ $tmp = $2;
+ $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
+ $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
+ $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
+ $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
+ $tmp eq 'R' && ($mess = "$file is not readable by you.");
+ $tmp eq 'W' && ($mess = "$file is not writable by you.");
+ $tmp eq 'X' && ($mess = "$file is not executable by you.");
+ $tmp eq 'O' && ($mess = "$file is not owned by you.");
+ $tmp eq 'e' && ($mess = "$file does not exist.");
+ $tmp eq 'z' && ($mess = "$file does not have zero size.");
+ $tmp eq 's' && ($mess = "$file does not have non-zero size.");
+ $tmp eq 'f' && ($mess = "$file is not a plain file.");
+ $tmp eq 'd' && ($mess = "$file is not a directory.");
+ $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
+ $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
+ $tmp eq 'S' && ($mess = "$file is not a socket.");
+ $tmp eq 'b' && ($mess = "$file is not a block special file.");
+ $tmp eq 'c' && ($mess = "$file is not a character special file.");
+ $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
+ $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
+ $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
+ $tmp eq 'T' && ($mess = "$file is not a text file.");
+ $tmp eq 'B' && ($mess = "$file is not a binary file.");
+ if ($neg eq '!') {
+ $mess =~ s/ is not / should not be / ||
+ $mess =~ s/ does not / should not / ||
+ $mess =~ s/ not / /;
+ }
+ print STDERR $mess,"\n";
+ }
+ else {
+ $this =~ s/\$file/'$file'/g;
+ print STDERR "Can't do $this.\n";
+ }
+ if ($disposition eq 'die') { exit 1; }
+ ++$warnings;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/vars.pm b/Master/tlpkg/tlperl/lib/vars.pm
new file mode 100644
index 00000000000..a0151b84030
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/vars.pm
@@ -0,0 +1,82 @@
+package vars;
+
+use 5.006;
+
+our $VERSION = '1.01';
+
+use warnings::register;
+use strict qw(vars subs);
+
+sub import {
+ my $callpack = caller;
+ my ($pack, @imports) = @_;
+ my ($sym, $ch);
+ foreach (@imports) {
+ if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) {
+ if ($sym =~ /\W/) {
+ # time for a more-detailed check-up
+ if ($sym =~ /^\w+[[{].*[]}]$/) {
+ require Carp;
+ Carp::croak("Can't declare individual elements of hash or array");
+ } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
+ warnings::warn("No need to declare built-in vars");
+ } elsif (($^H &= strict::bits('vars'))) {
+ require Carp;
+ Carp::croak("'$_' is not a valid variable name under strict vars");
+ }
+ }
+ $sym = "${callpack}::$sym" unless $sym =~ /::/;
+ *$sym =
+ ( $ch eq "\$" ? \$$sym
+ : $ch eq "\@" ? \@$sym
+ : $ch eq "\%" ? \%$sym
+ : $ch eq "\*" ? \*$sym
+ : $ch eq "\&" ? \&$sym
+ : do {
+ require Carp;
+ Carp::croak("'$_' is not a valid variable name");
+ });
+ } else {
+ require Carp;
+ Carp::croak("'$_' is not a valid variable name");
+ }
+ }
+};
+
+1;
+__END__
+
+=head1 NAME
+
+vars - Perl pragma to predeclare global variable names (obsolete)
+
+=head1 SYNOPSIS
+
+ use vars qw($frob @mung %seen);
+
+=head1 DESCRIPTION
+
+NOTE: For variables in the current package, the functionality provided
+by this pragma has been superseded by C<our> declarations, available
+in Perl v5.6.0 or later. See L<perlfunc/our>.
+
+This will predeclare all the variables whose names are
+in the list, allowing you to use them under "use strict", and
+disabling any typo warnings.
+
+Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
+C<use subs> declarations are not BLOCK-scoped. They are thus effective
+for the entire file in which they appear. You may not rescind such
+declarations with C<no vars> or C<no subs>.
+
+Packages such as the B<AutoLoader> and B<SelfLoader> that delay
+loading of subroutines within packages can create problems with
+package lexicals defined using C<my()>. While the B<vars> pragma
+cannot duplicate the effect of package lexicals (total transparency
+outside of the package), it can act as an acceptable substitute by
+pre-declaring global symbols, ensuring their availability to the
+later-loaded routines.
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/version.pm b/Master/tlpkg/tlperl/lib/version.pm
new file mode 100644
index 00000000000..405eb107741
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/version.pm
@@ -0,0 +1,171 @@
+#!perl -w
+package version;
+
+use 5.005_04;
+use strict;
+
+use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
+
+$VERSION = 0.82;
+
+$CLASS = 'version';
+
+#--------------------------------------------------------------------------#
+# Version regexp components
+#--------------------------------------------------------------------------#
+
+# Fraction part of a decimal version number. This is a common part of
+# both strict and lax decimal versions
+
+my $FRACTION_PART = qr/\.[0-9]+/;
+
+# First part of either decimal or dotted-decimal strict version number.
+# Unsigned integer with no leading zeroes (except for zero itself) to
+# avoid confusion with octal.
+
+my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
+
+# First part of either decimal or dotted-decimal lax version number.
+# Unsigned integer, but allowing leading zeros. Always interpreted
+# as decimal. However, some forms of the resulting syntax give odd
+# results if used as ordinary Perl expressions, due to how perl treats
+# octals. E.g.
+# version->new("010" ) == 10
+# version->new( 010 ) == 8
+# version->new( 010.2) == 82 # "8" . "2"
+
+my $LAX_INTEGER_PART = qr/[0-9]+/;
+
+# Second and subsequent part of a strict dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal.
+# Limited to three digits to avoid overflow when converting to decimal
+# form and also avoid problematic style with excessive leading zeroes.
+
+my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
+
+# Second and subsequent part of a lax dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal. No
+# limit on the numerical value or number of digits, so there is the
+# possibility of overflow when converting to decimal form.
+
+my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
+
+# Alpha suffix part of lax version number syntax. Acts like a
+# dotted-decimal part.
+
+my $LAX_ALPHA_PART = qr/_[0-9]+/;
+
+#--------------------------------------------------------------------------#
+# Strict version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Strict decimal version number.
+
+my $STRICT_DECIMAL_VERSION =
+ qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
+
+# Strict dotted-decimal version number. Must have both leading "v" and
+# at least three parts, to avoid confusion with decimal syntax.
+
+my $STRICT_DOTTED_DECIMAL_VERSION =
+ qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
+
+# Complete strict version number syntax -- should generally be used
+# anchored: qr/ \A $STRICT \z /x
+
+$STRICT =
+ qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+# Lax version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Lax decimal version number. Just like the strict one except for
+# allowing an alpha suffix or allowing a leading or trailing
+# decimal-point
+
+my $LAX_DECIMAL_VERSION =
+ qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
+ |
+ $FRACTION_PART $LAX_ALPHA_PART?
+ /x;
+
+# Lax dotted-decimal version number. Distinguished by having either
+# leading "v" or at least three non-alpha parts. Alpha part is only
+# permitted if there are at least two non-alpha parts. Strangely
+# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
+# so when there is no "v", the leading part is optional
+
+my $LAX_DOTTED_DECIMAL_VERSION =
+ qr/
+ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
+ |
+ $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
+ /x;
+
+# Complete lax version number syntax -- should generally be used
+# anchored: qr/ \A $LAX \z /x
+#
+# The string 'undef' is a special case to make for easier handling
+# of return values from ExtUtils::MM->parse_version
+
+$LAX =
+ qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+
+# Preloaded methods go here.
+sub import {
+ no strict 'refs';
+ my ($class) = shift;
+
+ # Set up any derived class
+ unless ($class eq 'version') {
+ local $^W;
+ *{$class.'::declare'} = \&version::declare;
+ *{$class.'::qv'} = \&version::qv;
+ }
+
+ my %args;
+ if (@_) { # any remaining terms are arguments
+ map { $args{$_} = 1 } @_
+ }
+ else { # no parameters at all on use line
+ %args =
+ (
+ qv => 1,
+ 'UNIVERSAL::VERSION' => 1,
+ );
+ }
+
+ my $callpkg = caller();
+
+ if (exists($args{declare})) {
+ *{$callpkg.'::declare'} =
+ sub {return $class->declare(shift) }
+ unless defined(&{$callpkg.'::declare'});
+ }
+
+ if (exists($args{qv})) {
+ *{$callpkg.'::qv'} =
+ sub {return $class->qv(shift) }
+ unless defined(&{$callpkg.'::qv'});
+ }
+
+ if (exists($args{'VERSION'})) {
+ *{$callpkg.'::VERSION'} = \&version::_VERSION;
+ }
+
+ if (exists($args{'is_strict'})) {
+ *{$callpkg.'::is_strict'} = \&version::is_strict;
+ }
+
+ if (exists($args{'is_lax'})) {
+ *{$callpkg.'::is_lax'} = \&version::is_lax;
+ }
+}
+
+sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
+sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/version.pod b/Master/tlpkg/tlperl/lib/version.pod
new file mode 100644
index 00000000000..a8cded81b0d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/version.pod
@@ -0,0 +1,321 @@
+=head1 NAME
+
+version - Perl extension for Version Objects
+
+=head1 SYNOPSIS
+
+ # Parsing version strings (decimal or dotted-decimal)
+
+ use version 0.77; # get latest bug-fixes and API
+ $ver = version->parse($string)
+
+ # Declaring a dotted-decimal $VERSION (keep on one line!)
+
+ use version 0.77; our $VERSION = version->declare("v1.2.3"); # formal
+ use version 0.77; our $VERSION = qv("v1.2.3"); # shorthand
+ use version 0.77; our $VERSION = qv("v1.2_3"); # alpha
+
+ # Declaring an old-style decimal $VERSION (use quotes!)
+
+ our $VERSION = "1.0203"; # recommended
+ use version 0.77; our $VERSION = version->parse("1.0203"); # formal
+ use version 0.77; our $VERSION = version->parse("1.02_03"); # alpha
+
+ # Comparing mixed version styles (decimals, dotted-decimals, objects)
+
+ if ( version->parse($v1) == version->parse($v2) ) {
+ # do stuff
+ }
+
+ # Sorting mixed version styles
+
+ @ordered = sort { version->parse($a) <=> version->parse($b) } @list;
+
+=head1 DESCRIPTION
+
+Version objects were added to Perl in 5.10. This module implements version
+objects for older version of Perl and provides the version object API for all
+versions of Perl. All previous releases before 0.74 are deprecated and should
+not be used due to incompatible API changes. Version 0.77 introduces the new
+'parse' and 'declare' methods to standardize usage. You are strongly urged to
+set 0.77 as a minimum in your code, e.g.
+
+ use version 0.77; # even for Perl v.5.10.0
+
+=head1 TYPES OF VERSION OBJECTS
+
+There are two different types of version objects, corresponding to the two
+different styles of versions in use:
+
+=over 2
+
+=item Decimal Versions
+
+The classic floating-point number $VERSION. The advantage to this style is
+that you don't need to do anything special, just type a number into your
+source file. Quoting is recommended, as it ensures that trailing zeroes
+("1.50") are preserved in any warnings or other output.
+
+=item Dotted Decimal Versions
+
+The more modern form of version assignment, with 3 (or potentially more)
+integers seperated by decimal points (e.g. v1.2.3). This is the form that
+Perl itself has used since 5.6.0 was released. The leading "v" is now
+strongly recommended for clarity, and will throw a warning in a future
+release if omitted.
+
+=back
+
+=head1 DECLARING VERSIONS
+
+If you have a module that uses a decimal $VERSION (floating point), and you
+do not intend to ever change that, this module is not for you. There is
+nothing that version.pm gains you over a simple $VERSION assignment:
+
+ our $VERSION = "1.02";
+
+Since Perl v5.10.0 includes the version.pm comparison logic anyways,
+you don't need to do anything at all.
+
+=head2 How to convert a module from decimal to dotted-decimal
+
+If you have used a decimal $VERSION in the past and wish to switch to a
+dotted-decimal $VERSION, then you need to make a one-time conversion to
+the new format.
+
+B<Important Note>: you must ensure that your new $VERSION is numerically
+greater than your current decimal $VERSION; this is not always obvious. First,
+convert your old decimal version (e.g. 1.02) to a normalized dotted-decimal
+form:
+
+ $ perl -Mversion -e 'print version->parse("1.02")->normal'
+ v1.20.0
+
+Then increment any of the dotted-decimal components (v1.20.1 or v1.21.0).
+
+=head2 How to C<declare()> a dotted-decimal version
+
+ use version 0.77; our $VERSION = version->declare("v1.2.3");
+
+The C<declare()> method always creates dotted-decimal version objects. When
+used in a module, you B<must> put it on the same line as "use version" to
+ensure that $VERSION is read correctly by PAUSE and installer tools. You
+should also add 'version' to the 'configure_requires' section of your
+module metadata file. See instructions in L<ExtUtils::MakeMaker> or
+L<Module::Build> for details.
+
+B<Important Note>: Even if you pass in what looks like a decimal number
+("1.2"), a dotted-decimal will be created ("v1.200.0"). To avoid confusion
+or unintentional errors on older Perls, follow these guidelines:
+
+=over 2
+
+=item *
+
+Always use a dotted-decimal with (at least) three components
+
+=item *
+
+Always use a leading-v
+
+=item *
+
+Always quote the version
+
+=back
+
+If you really insist on using version.pm with an ordinary decimal version,
+use C<parse()> instead of declare. See the L<PARSING AND COMPARING VERSIONS>
+for details.
+
+See also L<version::Internals> for more on version number conversion,
+quoting, calculated version numbers and declaring developer or "alpha" version
+numbers.
+
+=head1 PARSING AND COMPARING VERSIONS
+
+If you need to compare version numbers, but can't be sure whether they are
+expressed as numbers, strings, v-strings or version objects, then you should
+use version.pm to parse them all into objects for comparison.
+
+=head2 How to C<parse()> a version
+
+The C<parse()> method takes in anything that might be a version and returns
+a corresponding version object, doing any necessary conversion along the way.
+
+=over 2
+
+=item *
+
+Dotted-decimal: bare v-strings (v1.2.3) and strings with more than one
+decimal point and a leading 'v' ("v1.2.3"); NOTE you can technically use a
+v-string or strings with a leading-v and only one decimal point (v1.2 or
+"v1.2"), but you will confuse both yourself and others.
+
+=item *
+
+Decimal: regular decimal numbers (literal or in a string)
+
+=back
+
+Some examples:
+
+ $variable version->parse($variable)
+ --------- -------------------------
+ 1.23 v1.230.0
+ "1.23" v1.230.0
+ v1.23 v1.23.0
+ "v1.23" v1.23.0
+ "1.2.3" v1.2.3
+ "v1.2.3" v1.2.3
+
+See L<version::Internals> for more on version number conversion.
+
+=head2 How to check for a legal version string
+
+If you do not want to actually create a full blown version object, but
+would still like to verify that a given string meets the criteria to
+be parsed as a version, there are two helper functions that can be
+employed directly:
+
+=over 4
+
+=item C<is_lax()>
+
+The lax criteria corresponds to what is currently allowed by the
+version parser. All of the following formats are acceptable
+for dotted-decimal formats strings:
+
+ v1.2
+ 1.2345.6
+ v1.23_4
+ 1.2345
+ 1.2345_01
+
+=item C<is_strict()>
+
+If you want to limit youself to a much more narrow definition of what
+a version string constitutes, C<is_strict()> is limited to version
+strings like the following list:
+
+ v1.234.5
+ 2.3456
+
+=back
+
+See L<version::Internals> for details of the regular expressions
+that define the legal version string forms, as well as how to use
+those regular expressions in your own code if C<is_lax()> and
+C<is_strict()> are not sufficient for your needs.
+
+=head2 How to compare version objects
+
+Version objects overload the C<cmp> and C<< E<lt>=E<gt> >> operators. Perl
+automatically generates all of the other comparison operators based on those
+two so all the normal logical comparisons will work.
+
+ if ( version->parse($v1) == version->parse($v2) ) {
+ # do stuff
+ }
+
+If a version object is compared against a non-version object, the non-object
+term will be converted to a version object using C<parse()>. This may give
+surprising results:
+
+ $v1 = version->parse("v0.95.0");
+ $bool = $v1 < 0.96; # FALSE since 0.96 is v0.960.0
+
+Always comparing to a version object will help avoid surprises:
+
+ $bool = $v1 < version->parse("v0.96.0"); # TRUE
+
+Note that "alpha" version objects (where the version string contains
+a trailing underscore segment) compare as less than the equivalent
+version without an underscore:
+
+ $bool = version->parse("1.23_45") < version->parse("1.2345"); # TRUE
+
+See L<version::Internals> for more details on "alpha" versions.
+
+=head1 OBJECT METHODS
+
+=head2 is_alpha()
+
+True if and only if the version object was created with a underscore, e.g.
+
+ version->parse('1.002_03')->is_alpha; # TRUE
+ version->declare('1.2.3_4')->is_alpha; # TRUE
+
+=head2 is_qv()
+
+True only if the version object is a dotted-decimal version, e.g.
+
+ version->parse('v1.2.0')->is_qv; # TRUE
+ version->declare('v1.2')->is_qv; # TRUE
+ qv('1.2')->is_qv; # TRUE
+ version->parse('1.2')->is_qv; # FALSE
+
+=head2 normal()
+
+Returns a string with a standard 'normalized' dotted-decimal form with a
+leading-v and at least 3 components.
+
+ version->declare('v1.2')->normal; # v1.2.0
+ version->parse('1.2')->normal; # v1.200.0
+
+=head2 numify()
+
+Returns a value representing the object in a pure decimal form without
+trailing zeroes.
+
+ version->declare('v1.2')->numify; # 1.002
+ version->parse('1.2')->numify; # 1.2
+
+=head2 stringify()
+
+Returns a string that is as close to the original representation as possible.
+If the original representation was a numeric literal, it will be returned the
+way perl would normally represent it in a string. This method is used whenever
+a version object is interpolated into a string.
+
+ version->declare('v1.2')->stringify; # v1.2
+ version->parse('1.200')->stringify; # 1.200
+ version->parse(1.02_30)->stringify; # 1.023
+
+=head1 EXPORTED FUNCTIONS
+
+=head2 qv()
+
+This function is no longer recommended for use, but is maintained for
+compatibility with existing code. If you do not want to have it exported
+to your namespace, use this form:
+
+ use version 0.77 ();
+
+=head2 is_lax()
+
+(Not exported by default)
+
+This function takes a scalar argument and returns a boolean value indicating
+whether the argument meets the "lax" rules for a version number. Leading and
+trailing spaces are not allowed.
+
+=head2 is_strict()
+
+(Not exported by default)
+
+This function takes a scalar argument and returns a boolean value indicating
+whether the argument meets the "strict" rules for a version number. Leading
+and trailing spaces are not allowed.
+
+=head1 AUTHOR
+
+John Peacock E<lt>jpeacock@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<version::Internals>.
+
+L<perl>.
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/vmsish.pm b/Master/tlpkg/tlperl/lib/vmsish.pm
new file mode 100644
index 00000000000..30c8eb1656d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/vmsish.pm
@@ -0,0 +1,154 @@
+package vmsish;
+
+our $VERSION = '1.02';
+
+=head1 NAME
+
+vmsish - Perl pragma to control VMS-specific language features
+
+=head1 SYNOPSIS
+
+ use vmsish;
+
+ use vmsish 'status'; # or '$?'
+ use vmsish 'exit';
+ use vmsish 'time';
+
+ use vmsish 'hushed';
+ no vmsish 'hushed';
+ vmsish::hushed($hush);
+
+ use vmsish;
+ no vmsish 'time';
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible VMS-specific features are
+assumed. Currently, there are four VMS-specific features available:
+'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
+
+If you're not running VMS, this module does nothing.
+
+=over 6
+
+=item C<vmsish status>
+
+This makes C<$?> and C<system> return the native VMS exit status
+instead of emulating the POSIX exit status.
+
+=item C<vmsish exit>
+
+This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
+instead of emulating UNIX exit(), which considers C<exit 1> to indicate
+an error. As with the CRTL's exit() function, C<exit 0> is also mapped
+to an exit status of SS$_NORMAL, and any other argument to exit() is
+used directly as Perl's exit status.
+
+=item C<vmsish time>
+
+This makes all times relative to the local time zone, instead of the
+default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
+
+=item C<vmsish hushed>
+
+This suppresses printing of VMS status messages to SYS$OUTPUT and
+SYS$ERROR if Perl terminates with an error status. and allows
+programs that are expecting "unix-style" Perl to avoid having to parse
+VMS error messages. It does not suppress any messages from Perl
+itself, just the messages generated by DCL after Perl exits. The DCL
+symbol $STATUS will still have the termination status, but with a
+high-order bit set:
+
+EXAMPLE:
+ $ perl -e"exit 44;" Non-hushed error exit
+ %SYSTEM-F-ABORT, abort DCL message
+ $ show sym $STATUS
+ $STATUS == "%X0000002C"
+
+ $ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit
+ $ show sym $STATUS
+ $STATUS == "%X1000002C"
+
+The 'hushed' flag has a global scope during compilation: the exit() or
+die() commands that are compiled after 'vmsish hushed' will be hushed
+when they are executed. Doing a "no vmsish 'hushed'" turns off the
+hushed flag.
+
+The status of the hushed flag also affects output of VMS error
+messages from compilation errors. Again, you still get the Perl
+error message (and the code in $STATUS)
+
+EXAMPLE:
+ use vmsish 'hushed'; # turn on hushed flag
+ use Carp; # Carp compiled hushed
+ exit 44; # will be hushed
+ croak('I die'); # will be hushed
+ no vmsish 'hushed'; # turn off hushed flag
+ exit 44; # will not be hushed
+ croak('I die2'): # WILL be hushed, croak was compiled hushed
+
+You can also control the 'hushed' flag at run-time, using the built-in
+routine vmsish::hushed(). Without argument, it returns the hushed status.
+Since vmsish::hushed is built-in, you do not need to "use vmsish" to call
+it.
+
+EXAMPLE:
+ if ($quiet_exit) {
+ vmsish::hushed(1);
+ }
+ print "Sssshhhh...I'm hushed...\n" if vmsish::hushed();
+ exit 44;
+
+Note that an exit() or die() that is compiled 'hushed' because of "use
+vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime.
+
+The messages from error exits from inside the Perl core are generally
+more serious, and are not suppressed.
+
+=back
+
+See L<perlmod/Pragmatic Modules>.
+
+=cut
+
+my $IsVMS = $^O eq 'VMS';
+
+sub bits {
+ my $bits = 0;
+ my $sememe;
+ foreach $sememe (@_) {
+ # Those hints are defined in vms/vmsish.h :
+ # HINT_M_VMSISH_STATUS and HINT_M_VMSISH_TIME
+ $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
+ $bits |= 0x80000000, next if $sememe eq 'time';
+ }
+ $bits;
+}
+
+sub import {
+ return unless $IsVMS;
+
+ shift;
+ $^H |= bits(@_ ? @_ : qw(status time));
+ my $sememe;
+
+ foreach $sememe (@_ ? @_ : qw(exit hushed)) {
+ $^H{'vmsish_exit'} = 1 if $sememe eq 'exit';
+ vmsish::hushed(1) if $sememe eq 'hushed';
+ }
+}
+
+sub unimport {
+ return unless $IsVMS;
+
+ shift;
+ $^H &= ~ bits(@_ ? @_ : qw(status time));
+ my $sememe;
+
+ foreach $sememe (@_ ? @_ : qw(exit hushed)) {
+ $^H{'vmsish_exit'} = 0 if $sememe eq 'exit';
+ vmsish::hushed(0) if $sememe eq 'hushed';
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/warnings.pm b/Master/tlpkg/tlperl/lib/warnings.pm
new file mode 100644
index 00000000000..defc20890b3
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/warnings.pm
@@ -0,0 +1,544 @@
+# -*- buffer-read-only: t -*-
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file was created by warnings.pl
+# Any changes made here will be lost.
+#
+
+package warnings;
+
+our $VERSION = '1.09';
+
+# Verify that we're called correctly so that warnings will work.
+# see also strict.pm.
+unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
+ my (undef, $f, $l) = caller;
+ die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
+}
+
+=head1 NAME
+
+warnings - Perl pragma to control optional warnings
+
+=head1 SYNOPSIS
+
+ use warnings;
+ no warnings;
+
+ use warnings "all";
+ no warnings "all";
+
+ use warnings::register;
+ if (warnings::enabled()) {
+ warnings::warn("some warning");
+ }
+
+ if (warnings::enabled("void")) {
+ warnings::warn("void", "some warning");
+ }
+
+ if (warnings::enabled($object)) {
+ warnings::warn($object, "some warning");
+ }
+
+ warnings::warnif("some warning");
+ warnings::warnif("void", "some warning");
+ warnings::warnif($object, "some warning");
+
+=head1 DESCRIPTION
+
+The C<warnings> pragma is a replacement for the command line flag C<-w>,
+but the pragma is limited to the enclosing block, while the flag is global.
+See L<perllexwarn> for more information.
+
+If no import list is supplied, all possible warnings are either enabled
+or disabled.
+
+A number of functions are provided to assist module authors.
+
+=over 4
+
+=item use warnings::register
+
+Creates a new warnings category with the same name as the package where
+the call to the pragma is used.
+
+=item warnings::enabled()
+
+Use the warnings category with the same name as the current package.
+
+Return TRUE if that warnings category is enabled in the calling module.
+Otherwise returns FALSE.
+
+=item warnings::enabled($category)
+
+Return TRUE if the warnings category, C<$category>, is enabled in the
+calling module.
+Otherwise returns FALSE.
+
+=item warnings::enabled($object)
+
+Use the name of the class for the object reference, C<$object>, as the
+warnings category.
+
+Return TRUE if that warnings category is enabled in the first scope
+where the object is used.
+Otherwise returns FALSE.
+
+=item warnings::fatal_enabled()
+
+Return TRUE if the warnings category with the same name as the current
+package has been set to FATAL in the calling module.
+Otherwise returns FALSE.
+
+=item warnings::fatal_enabled($category)
+
+Return TRUE if the warnings category C<$category> has been set to FATAL in
+the calling module.
+Otherwise returns FALSE.
+
+=item warnings::fatal_enabled($object)
+
+Use the name of the class for the object reference, C<$object>, as the
+warnings category.
+
+Return TRUE if that warnings category has been set to FATAL in the first
+scope where the object is used.
+Otherwise returns FALSE.
+
+=item warnings::warn($message)
+
+Print C<$message> to STDERR.
+
+Use the warnings category with the same name as the current package.
+
+If that warnings category has been set to "FATAL" in the calling module
+then die. Otherwise return.
+
+=item warnings::warn($category, $message)
+
+Print C<$message> to STDERR.
+
+If the warnings category, C<$category>, has been set to "FATAL" in the
+calling module then die. Otherwise return.
+
+=item warnings::warn($object, $message)
+
+Print C<$message> to STDERR.
+
+Use the name of the class for the object reference, C<$object>, as the
+warnings category.
+
+If that warnings category has been set to "FATAL" in the scope where C<$object>
+is first used then die. Otherwise return.
+
+
+=item warnings::warnif($message)
+
+Equivalent to:
+
+ if (warnings::enabled())
+ { warnings::warn($message) }
+
+=item warnings::warnif($category, $message)
+
+Equivalent to:
+
+ if (warnings::enabled($category))
+ { warnings::warn($category, $message) }
+
+=item warnings::warnif($object, $message)
+
+Equivalent to:
+
+ if (warnings::enabled($object))
+ { warnings::warn($object, $message) }
+
+=back
+
+See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
+
+=cut
+
+our %Offsets = (
+
+ # Warnings Categories added in Perl 5.008
+
+ 'all' => 0,
+ 'closure' => 2,
+ 'deprecated' => 4,
+ 'exiting' => 6,
+ 'glob' => 8,
+ 'io' => 10,
+ 'closed' => 12,
+ 'exec' => 14,
+ 'layer' => 16,
+ 'newline' => 18,
+ 'pipe' => 20,
+ 'unopened' => 22,
+ 'misc' => 24,
+ 'numeric' => 26,
+ 'once' => 28,
+ 'overflow' => 30,
+ 'pack' => 32,
+ 'portable' => 34,
+ 'recursion' => 36,
+ 'redefine' => 38,
+ 'regexp' => 40,
+ 'severe' => 42,
+ 'debugging' => 44,
+ 'inplace' => 46,
+ 'internal' => 48,
+ 'malloc' => 50,
+ 'signal' => 52,
+ 'substr' => 54,
+ 'syntax' => 56,
+ 'ambiguous' => 58,
+ 'bareword' => 60,
+ 'digit' => 62,
+ 'parenthesis' => 64,
+ 'precedence' => 66,
+ 'printf' => 68,
+ 'prototype' => 70,
+ 'qw' => 72,
+ 'reserved' => 74,
+ 'semicolon' => 76,
+ 'taint' => 78,
+ 'threads' => 80,
+ 'uninitialized' => 82,
+ 'unpack' => 84,
+ 'untie' => 86,
+ 'utf8' => 88,
+ 'void' => 90,
+
+ # Warnings Categories added in Perl 5.011
+
+ 'imprecision' => 92,
+ 'illegalproto' => 94,
+ );
+
+our %Bits = (
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
+ 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
+ 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
+ );
+
+our %DeadBits = (
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
+ 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
+ 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
+ );
+
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
+$LAST_BIT = 96 ;
+$BYTES = 12 ;
+
+$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
+
+sub Croaker
+{
+ require Carp; # this initializes %CarpInternal
+ local $Carp::CarpInternal{'warnings'};
+ delete $Carp::CarpInternal{'warnings'};
+ Carp::croak(@_);
+}
+
+sub bits
+{
+ # called from B::Deparse.pm
+
+ push @_, 'all' unless @_;
+
+ my $mask;
+ my $catmask ;
+ my $fatal = 0 ;
+ my $no_fatal = 0 ;
+
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ $fatal = 1;
+ $no_fatal = 0;
+ }
+ elsif ($word eq 'NONFATAL') {
+ $fatal = 0;
+ $no_fatal = 1;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ return $mask ;
+}
+
+sub import
+{
+ shift;
+
+ my $catmask ;
+ my $fatal = 0 ;
+ my $no_fatal = 0 ;
+
+ my $mask = ${^WARNING_BITS} ;
+
+ if (vec($mask, $Offsets{'all'}, 1)) {
+ $mask |= $Bits{'all'} ;
+ $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+ }
+
+ push @_, 'all' unless @_;
+
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ $fatal = 1;
+ $no_fatal = 0;
+ }
+ elsif ($word eq 'NONFATAL') {
+ $fatal = 0;
+ $no_fatal = 1;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ ${^WARNING_BITS} = $mask ;
+}
+
+sub unimport
+{
+ shift;
+
+ my $catmask ;
+ my $mask = ${^WARNING_BITS} ;
+
+ if (vec($mask, $Offsets{'all'}, 1)) {
+ $mask |= $Bits{'all'} ;
+ $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+ }
+
+ push @_, 'all' unless @_;
+
+ foreach my $word ( @_ ) {
+ if ($word eq 'FATAL') {
+ next;
+ }
+ elsif ($catmask = $Bits{$word}) {
+ $mask &= ~($catmask | $DeadBits{$word} | $All);
+ }
+ else
+ { Croaker("Unknown warnings category '$word'")}
+ }
+
+ ${^WARNING_BITS} = $mask ;
+}
+
+my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
+
+sub __chk
+{
+ my $category ;
+ my $offset ;
+ my $isobj = 0 ;
+
+ if (@_) {
+ # check the category supplied.
+ $category = shift ;
+ if (my $type = ref $category) {
+ Croaker("not an object")
+ if exists $builtin_type{$type};
+ $category = $type;
+ $isobj = 1 ;
+ }
+ $offset = $Offsets{$category};
+ Croaker("Unknown warnings category '$category'")
+ unless defined $offset;
+ }
+ else {
+ $category = (caller(1))[0] ;
+ $offset = $Offsets{$category};
+ Croaker("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ my $this_pkg = (caller(1))[0] ;
+ my $i = 2 ;
+ my $pkg ;
+
+ if ($isobj) {
+ while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
+ last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
+ }
+ $i -= 2 ;
+ }
+ else {
+ $i = _error_loc(); # see where Carp will allocate the error
+ }
+
+ my $callers_bitmask = (caller($i))[9] ;
+ return ($callers_bitmask, $offset, $i) ;
+}
+
+sub _error_loc {
+ require Carp;
+ goto &Carp::short_error_loc; # don't introduce another stack frame
+}
+
+sub enabled
+{
+ Croaker("Usage: warnings::enabled([category])")
+ unless @_ == 1 || @_ == 0 ;
+
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+
+ return 0 unless defined $callers_bitmask ;
+ return vec($callers_bitmask, $offset, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}, 1) ;
+}
+
+sub fatal_enabled
+{
+ Croaker("Usage: warnings::fatal_enabled([category])")
+ unless @_ == 1 || @_ == 0 ;
+
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+
+ return 0 unless defined $callers_bitmask;
+ return vec($callers_bitmask, $offset + 1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
+}
+
+sub warn
+{
+ Croaker("Usage: warnings::warn([category,] 'message')")
+ unless @_ == 2 || @_ == 1 ;
+
+ my $message = pop ;
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+ require Carp;
+ Carp::croak($message)
+ if vec($callers_bitmask, $offset+1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
+ Carp::carp($message) ;
+}
+
+sub warnif
+{
+ Croaker("Usage: warnings::warnif([category,] 'message')")
+ unless @_ == 2 || @_ == 1 ;
+
+ my $message = pop ;
+ my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+
+ return
+ unless defined $callers_bitmask &&
+ (vec($callers_bitmask, $offset, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}, 1)) ;
+
+ require Carp;
+ Carp::croak($message)
+ if vec($callers_bitmask, $offset+1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
+
+ Carp::carp($message) ;
+}
+
+1;
+# ex: set ro: